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 3, 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 COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "gfortran.h"
  25 #include "match.h"
  26 #include "parse.h"
  27
  28 /* This flag is set if an old-style length selector is matched
  29    during a type-declaration statement.  */
  30
  31 static int old_char_selector;
  32
  33 /* When variables acquire types and attributes from a declaration
  34    statement, they get them from the following static variables.  The
  35    first part of a declaration sets these variables and the second
  36    part copies these into symbol structures.  */
  37
  38 static gfc_typespec current_ts;
  39
  40 static symbol_attribute current_attr;
  41 static gfc_array_spec *current_as;
  42 static int colon_seen;
  43
  44 /* The current binding label (if any).  */
  45 static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
  46 /* Need to know how many identifiers are on the current data declaration
  47    line in case we're given the BIND(C) attribute with a NAME= specifier.  */
  48 static int num_idents_on_line;
  49 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
  50    can supply a name if the curr_binding_label is nil and NAME= was not.  */
  51 static int has_name_equals = 0;
  52
  53 /* Initializer of the previous enumerator.  */
  54
  55 static gfc_expr *last_initializer;
  56
  57 /* History of all the enumerators is maintained, so that
  58    kind values of all the enumerators could be updated depending
  59    upon the maximum initialized value.  */
  60
  61 typedef struct enumerator_history
  62 {
  63   gfc_symbol *sym;
  64   gfc_expr *initializer;
  65   struct enumerator_history *next;
  66 }
  67 enumerator_history;
  68
  69 /* Header of enum history chain.  */
  70
  71 static enumerator_history *enum_history = NULL;
  72
  73 /* Pointer of enum history node containing largest initializer.  */
  74
  75 static enumerator_history *max_enum = NULL;
  76
  77 /* gfc_new_block points to the symbol of a newly matched block.  */
  78
  79 gfc_symbol *gfc_new_block;
  80
  81
  82 /********************* DATA statement subroutines *********************/
  83
  84 static bool in_match_data = false;
  85
  86 bool
  87 gfc_in_match_data (void)
  88 {
  89   return in_match_data;
  90 }
  91
  92 void
  93 gfc_set_in_match_data (bool set_value)
  94 {
  95   in_match_data = set_value;
  96 }
  97
  98 /* Free a gfc_data_variable structure and everything beneath it.  */
  99
 100 static void
 101 free_variable (gfc_data_variable *p)
 102 {
 103   gfc_data_variable *q;
 104
 105   for (; p; p = q)
 106     {
 107       q = p->next;
 108       gfc_free_expr (p->expr);
 109       gfc_free_iterator (&p->iter, 0);
 110       free_variable (p->list);
 111       gfc_free (p);
 112     }
 113 }
 114
 115
 116 /* Free a gfc_data_value structure and everything beneath it.  */
 117
 118 static void
 119 free_value (gfc_data_value *p)
 120 {
 121   gfc_data_value *q;
 122
 123   for (; p; p = q)
 124     {
 125       q = p->next;
 126       gfc_free_expr (p->expr);
 127       gfc_free (p);
 128     }
 129 }
 130
 131
 132 /* Free a list of gfc_data structures.  */
 133
 134 void
 135 gfc_free_data (gfc_data *p)
 136 {
 137   gfc_data *q;
 138
 139   for (; p; p = q)
 140     {
 141       q = p->next;
 142       free_variable (p->var);
 143       free_value (p->value);
 144       gfc_free (p);
 145     }
 146 }
 147
 148
 149 /* Free all data in a namespace.  */
 150
 151 static void
 152 gfc_free_data_all (gfc_namespace *ns)
 153 {
 154   gfc_data *d;
 155
 156   for (;ns->data;)
 157     {
 158       d = ns->data->next;
 159       gfc_free (ns->data);
 160       ns->data = d;
 161     }
 162 }
 163
 164
 165 static match var_element (gfc_data_variable *);
 166
 167 /* Match a list of variables terminated by an iterator and a right
 168    parenthesis.  */
 169
 170 static match
 171 var_list (gfc_data_variable *parent)
 172 {
 173   gfc_data_variable *tail, var;
 174   match m;
 175
 176   m = var_element (&var);
 177   if (m == MATCH_ERROR)
 178     return MATCH_ERROR;
 179   if (m == MATCH_NO)
 180     goto syntax;
 181
 182   tail = gfc_get_data_variable ();
 183   *tail = var;
 184
 185   parent->list = tail;
 186
 187   for (;;)
 188     {
 189       if (gfc_match_char (',') != MATCH_YES)
 190         goto syntax;
 191
 192       m = gfc_match_iterator (&parent->iter, 1);
 193       if (m == MATCH_YES)
 194         break;
 195       if (m == MATCH_ERROR)
 196         return MATCH_ERROR;
 197
 198       m = var_element (&var);
 199       if (m == MATCH_ERROR)
 200         return MATCH_ERROR;
 201       if (m == MATCH_NO)
 202         goto syntax;
 203
 204       tail->next = gfc_get_data_variable ();
 205       tail = tail->next;
 206
 207       *tail = var;
 208     }
 209
 210   if (gfc_match_char (')') != MATCH_YES)
 211     goto syntax;
 212   return MATCH_YES;
 213
 214 syntax:
 215   gfc_syntax_error (ST_DATA);
 216   return MATCH_ERROR;
 217 }
 218
 219
 220 /* Match a single element in a data variable list, which can be a
 221    variable-iterator list.  */
 222
 223 static match
 224 var_element (gfc_data_variable *new)
 225 {
 226   match m;
 227   gfc_symbol *sym;
 228
 229   memset (new, 0, sizeof (gfc_data_variable));
 230
 231   if (gfc_match_char ('(') == MATCH_YES)
 232     return var_list (new);
 233
 234   m = gfc_match_variable (&new->expr, 0);
 235   if (m != MATCH_YES)
 236     return m;
 237
 238   sym = new->expr->symtree->n.sym;
 239
 240   if (!sym->attr.function && gfc_current_ns->parent
 241       && gfc_current_ns->parent == sym->ns)
 242     {
 243       gfc_error ("Host associated variable '%s' may not be in the DATA "
 244                  "statement at %C", sym->name);
 245       return MATCH_ERROR;
 246     }
 247
 248   if (gfc_current_state () != COMP_BLOCK_DATA
 249       && sym->attr.in_common
 250       && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
 251                          "common block variable '%s' in DATA statement at %C",
 252                          sym->name) == FAILURE)
 253     return MATCH_ERROR;
 254
 255   if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
 256     return MATCH_ERROR;
 257
 258   return MATCH_YES;
 259 }
 260
 261
 262 /* Match the top-level list of data variables.  */
 263
 264 static match
 265 top_var_list (gfc_data *d)
 266 {
 267   gfc_data_variable var, *tail, *new;
 268   match m;
 269
 270   tail = NULL;
 271
 272   for (;;)
 273     {
 274       m = var_element (&var);
 275       if (m == MATCH_NO)
 276         goto syntax;
 277       if (m == MATCH_ERROR)
 278         return MATCH_ERROR;
 279
 280       new = gfc_get_data_variable ();
 281       *new = var;
 282
 283       if (tail == NULL)
 284         d->var = new;
 285       else
 286         tail->next = new;
 287
 288       tail = new;
 289
 290       if (gfc_match_char ('/') == MATCH_YES)
 291         break;
 292       if (gfc_match_char (',') != MATCH_YES)
 293         goto syntax;
 294     }
 295
 296   return MATCH_YES;
 297
 298 syntax:
 299   gfc_syntax_error (ST_DATA);
 300   gfc_free_data_all (gfc_current_ns);
 301   return MATCH_ERROR;
 302 }
 303
 304
 305 static match
 306 match_data_constant (gfc_expr **result)
 307 {
 308   char name[GFC_MAX_SYMBOL_LEN + 1];
 309   gfc_symbol *sym;
 310   gfc_expr *expr;
 311   match m;
 312   locus old_loc;
 313
 314   m = gfc_match_literal_constant (&expr, 1);
 315   if (m == MATCH_YES)
 316     {
 317       *result = expr;
 318       return MATCH_YES;
 319     }
 320
 321   if (m == MATCH_ERROR)
 322     return MATCH_ERROR;
 323
 324   m = gfc_match_null (result);
 325   if (m != MATCH_NO)
 326     return m;
 327
 328   old_loc = gfc_current_locus;
 329
 330   /* Should this be a structure component, try to match it
 331      before matching a name.  */
 332   m = gfc_match_rvalue (result);
 333   if (m == MATCH_ERROR)
 334     return m;
 335
 336   if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
 337     {
 338       if (gfc_simplify_expr (*result, 0) == FAILURE)
 339         m = MATCH_ERROR;
 340       return m;
 341     }
 342
 343   gfc_current_locus = old_loc;
 344
 345   m = gfc_match_name (name);
 346   if (m != MATCH_YES)
 347     return m;
 348
 349   if (gfc_find_symbol (name, NULL, 1, &sym))
 350     return MATCH_ERROR;
 351
 352   if (sym == NULL
 353       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
 354     {
 355       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
 356                  name);
 357       return MATCH_ERROR;
 358     }
 359   else if (sym->attr.flavor == FL_DERIVED)
 360     return gfc_match_structure_constructor (sym, result);
 361
 362   *result = gfc_copy_expr (sym->value);
 363   return MATCH_YES;
 364 }
 365
 366
 367 /* Match a list of values in a DATA statement.  The leading '/' has
 368    already been seen at this point.  */
 369
 370 static match
 371 top_val_list (gfc_data *data)
 372 {
 373   gfc_data_value *new, *tail;
 374   gfc_expr *expr;
 375   const char *msg;
 376   match m;
 377
 378   tail = NULL;
 379
 380   for (;;)
 381     {
 382       m = match_data_constant (&expr);
 383       if (m == MATCH_NO)
 384         goto syntax;
 385       if (m == MATCH_ERROR)
 386         return MATCH_ERROR;
 387
 388       new = gfc_get_data_value ();
 389
 390       if (tail == NULL)
 391         data->value = new;
 392       else
 393         tail->next = new;
 394
 395       tail = new;
 396
 397       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
 398         {
 399           tail->expr = expr;
 400           tail->repeat = 1;
 401         }
 402       else
 403         {
 404           signed int tmp;
 405           msg = gfc_extract_int (expr, &tmp);
 406           gfc_free_expr (expr);
 407           if (msg != NULL)
 408             {
 409               gfc_error (msg);
 410               return MATCH_ERROR;
 411             }
 412           tail->repeat = tmp;
 413
 414           m = match_data_constant (&tail->expr);
 415           if (m == MATCH_NO)
 416             goto syntax;
 417           if (m == MATCH_ERROR)
 418             return MATCH_ERROR;
 419         }
 420
 421       if (gfc_match_char ('/') == MATCH_YES)
 422         break;
 423       if (gfc_match_char (',') == MATCH_NO)
 424         goto syntax;
 425     }
 426
 427   return MATCH_YES;
 428
 429 syntax:
 430   gfc_syntax_error (ST_DATA);
 431   gfc_free_data_all (gfc_current_ns);
 432   return MATCH_ERROR;
 433 }
 434
 435
 436 /* Matches an old style initialization.  */
 437
 438 static match
 439 match_old_style_init (const char *name)
 440 {
 441   match m;
 442   gfc_symtree *st;
 443   gfc_symbol *sym;
 444   gfc_data *newdata;
 445
 446   /* Set up data structure to hold initializers.  */
 447   gfc_find_sym_tree (name, NULL, 0, &st);
 448   sym = st->n.sym;
 449
 450   newdata = gfc_get_data ();
 451   newdata->var = gfc_get_data_variable ();
 452   newdata->var->expr = gfc_get_variable_expr (st);
 453   newdata->where = gfc_current_locus;
 454
 455   /* Match initial value list. This also eats the terminal '/'.  */
 456   m = top_val_list (newdata);
 457   if (m != MATCH_YES)
 458     {
 459       gfc_free (newdata);
 460       return m;
 461     }
 462
 463   if (gfc_pure (NULL))
 464     {
 465       gfc_error ("Initialization at %C is not allowed in a PURE procedure");
 466       gfc_free (newdata);
 467       return MATCH_ERROR;
 468     }
 469
 470   /* Mark the variable as having appeared in a data statement.  */
 471   if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
 472     {
 473       gfc_free (newdata);
 474       return MATCH_ERROR;
 475     }
 476
 477   /* Chain in namespace list of DATA initializers.  */
 478   newdata->next = gfc_current_ns->data;
 479   gfc_current_ns->data = newdata;
 480
 481   return m;
 482 }
 483
 484
 485 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
 486    we are matching a DATA statement and are therefore issuing an error
 487    if we encounter something unexpected, if not, we're trying to match
 488    an old-style initialization expression of the form INTEGER I /2/.  */
 489
 490 match
 491 gfc_match_data (void)
 492 {
 493   gfc_data *new;
 494   match m;
 495
 496   gfc_set_in_match_data (true);
 497
 498   for (;;)
 499     {
 500       new = gfc_get_data ();
 501       new->where = gfc_current_locus;
 502
 503       m = top_var_list (new);
 504       if (m != MATCH_YES)
 505         goto cleanup;
 506
 507       m = top_val_list (new);
 508       if (m != MATCH_YES)
 509         goto cleanup;
 510
 511       new->next = gfc_current_ns->data;
 512       gfc_current_ns->data = new;
 513
 514       if (gfc_match_eos () == MATCH_YES)
 515         break;
 516
 517       gfc_match_char (',');     /* Optional comma */
 518     }
 519
 520   gfc_set_in_match_data (false);
 521
 522   if (gfc_pure (NULL))
 523     {
 524       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
 525       return MATCH_ERROR;
 526     }
 527
 528   return MATCH_YES;
 529
 530 cleanup:
 531   gfc_set_in_match_data (false);
 532   gfc_free_data (new);
 533   return MATCH_ERROR;
 534 }
 535
 536
 537 /************************ Declaration statements *********************/
 538
 539 /* Match an intent specification.  Since this can only happen after an
 540    INTENT word, a legal intent-spec must follow.  */
 541
 542 static sym_intent
 543 match_intent_spec (void)
 544 {
 545
 546   if (gfc_match (" ( in out )") == MATCH_YES)
 547     return INTENT_INOUT;
 548   if (gfc_match (" ( in )") == MATCH_YES)
 549     return INTENT_IN;
 550   if (gfc_match (" ( out )") == MATCH_YES)
 551     return INTENT_OUT;
 552
 553   gfc_error ("Bad INTENT specification at %C");
 554   return INTENT_UNKNOWN;
 555 }
 556
 557
 558 /* Matches a character length specification, which is either a
 559    specification expression or a '*'.  */
 560
 561 static match
 562 char_len_param_value (gfc_expr **expr)
 563 {
 564   if (gfc_match_char ('*') == MATCH_YES)
 565     {
 566       *expr = NULL;
 567       return MATCH_YES;
 568     }
 569
 570   return gfc_match_expr (expr);
 571 }
 572
 573
 574 /* A character length is a '*' followed by a literal integer or a
 575    char_len_param_value in parenthesis.  */
 576
 577 static match
 578 match_char_length (gfc_expr **expr)
 579 {
 580   int length;
 581   match m;
 582
 583   m = gfc_match_char ('*');
 584   if (m != MATCH_YES)
 585     return m;
 586
 587   m = gfc_match_small_literal_int (&length, NULL);
 588   if (m == MATCH_ERROR)
 589     return m;
 590
 591   if (m == MATCH_YES)
 592     {
 593       *expr = gfc_int_expr (length);
 594       return m;
 595     }
 596
 597   if (gfc_match_char ('(') == MATCH_NO)
 598     goto syntax;
 599
 600   m = char_len_param_value (expr);
 601   if (m == MATCH_ERROR)
 602     return m;
 603   if (m == MATCH_NO)
 604     goto syntax;
 605
 606   if (gfc_match_char (')') == MATCH_NO)
 607     {
 608       gfc_free_expr (*expr);
 609       *expr = NULL;
 610       goto syntax;
 611     }
 612
 613   return MATCH_YES;
 614
 615 syntax:
 616   gfc_error ("Syntax error in character length specification at %C");
 617   return MATCH_ERROR;
 618 }
 619
 620
 621 /* Special subroutine for finding a symbol.  Check if the name is found
 622    in the current name space.  If not, and we're compiling a function or
 623    subroutine and the parent compilation unit is an interface, then check
 624    to see if the name we've been given is the name of the interface
 625    (located in another namespace).  */
 626
 627 static int
 628 find_special (const char *name, gfc_symbol **result)
 629 {
 630   gfc_state_data *s;
 631   int i;
 632
 633   i = gfc_get_symbol (name, NULL, result);
 634   if (i == 0)
 635     goto end;
 636
 637   if (gfc_current_state () != COMP_SUBROUTINE
 638       && gfc_current_state () != COMP_FUNCTION)
 639     goto end;
 640
 641   s = gfc_state_stack->previous;
 642   if (s == NULL)
 643     goto end;
 644
 645   if (s->state != COMP_INTERFACE)
 646     goto end;
 647   if (s->sym == NULL)
 648     goto end;             /* Nameless interface.  */
 649
 650   if (strcmp (name, s->sym->name) == 0)
 651     {
 652       *result = s->sym;
 653       return 0;
 654     }
 655
 656 end:
 657   return i;
 658 }
 659
 660
 661 /* Special subroutine for getting a symbol node associated with a
 662    procedure name, used in SUBROUTINE and FUNCTION statements.  The
 663    symbol is created in the parent using with symtree node in the
 664    child unit pointing to the symbol.  If the current namespace has no
 665    parent, then the symbol is just created in the current unit.  */
 666
 667 static int
 668 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
 669 {
 670   gfc_symtree *st;
 671   gfc_symbol *sym;
 672   int rc;
 673
 674   /* Module functions have to be left in their own namespace because
 675      they have potentially (almost certainly!) already been referenced.
 676      In this sense, they are rather like external functions.  This is
 677      fixed up in resolve.c(resolve_entries), where the symbol name-
 678      space is set to point to the master function, so that the fake
 679      result mechanism can work.  */
 680   if (module_fcn_entry)
 681     {
 682       /* Present if entry is declared to be a module procedure.  */
 683       rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
 684
 685       if (*result == NULL)
 686         rc = gfc_get_symbol (name, NULL, result);
 687       else if (gfc_get_symbol (name, NULL, &sym) == 0
 688                  && sym
 689                  && sym->ts.type != BT_UNKNOWN
 690                  && (*result)->ts.type == BT_UNKNOWN
 691                  && sym->attr.flavor == FL_UNKNOWN)
 692         /* Pick up the typespec for the entry, if declared in the function
 693            body.  Note that this symbol is FL_UNKNOWN because it will
 694            only have appeared in a type declaration.  The local symtree
 695            is set to point to the module symbol and a unique symtree
 696            to the local version.  This latter ensures a correct clearing
 697            of the symbols.  */
 698           {
 699             (*result)->ts = sym->ts;
 700             gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
 701             st->n.sym = *result;
 702             st = gfc_get_unique_symtree (gfc_current_ns);
 703             st->n.sym = sym;
 704           }
 705     }
 706   else
 707     rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
 708
 709   sym = *result;
 710   gfc_current_ns->refs++;
 711
 712   if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
 713     {
 714       /* Trap another encompassed procedure with the same name.  All
 715          these conditions are necessary to avoid picking up an entry
 716          whose name clashes with that of the encompassing procedure;
 717          this is handled using gsymbols to register unique,globally
 718          accessible names.  */
 719       if (sym->attr.flavor != 0
 720           && sym->attr.proc != 0
 721           && (sym->attr.subroutine || sym->attr.function)
 722           && sym->attr.if_source != IFSRC_UNKNOWN)
 723         gfc_error_now ("Procedure '%s' at %C is already defined at %L",
 724                        name, &sym->declared_at);
 725
 726       /* Trap a procedure with a name the same as interface in the
 727          encompassing scope.  */
 728       if (sym->attr.generic != 0
 729           && (sym->attr.subroutine || sym->attr.function)
 730           && !sym->attr.mod_proc)
 731         gfc_error_now ("Name '%s' at %C is already defined"
 732                        " as a generic interface at %L",
 733                        name, &sym->declared_at);
 734
 735       /* Trap declarations of attributes in encompassing scope.  The
 736          signature for this is that ts.kind is set.  Legitimate
 737          references only set ts.type.  */
 738       if (sym->ts.kind != 0
 739           && !sym->attr.implicit_type
 740           && sym->attr.proc == 0
 741           && gfc_current_ns->parent != NULL
 742           && sym->attr.access == 0
 743           && !module_fcn_entry)
 744         gfc_error_now ("Procedure '%s' at %C has an explicit interface "
 745                        "and must not have attributes declared at %L",
 746                        name, &sym->declared_at);
 747     }
 748
 749   if (gfc_current_ns->parent == NULL || *result == NULL)
 750     return rc;
 751
 752   /* Module function entries will already have a symtree in
 753      the current namespace but will need one at module level.  */
 754   if (module_fcn_entry)
 755     {
 756       /* Present if entry is declared to be a module procedure.  */
 757       rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
 758       if (st == NULL)
 759         st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
 760     }
 761   else
 762     st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 763
 764   st->n.sym = sym;
 765   sym->refs++;
 766
 767   /* See if the procedure should be a module procedure.  */
 768
 769   if (((sym->ns->proc_name != NULL
 770                 && sym->ns->proc_name->attr.flavor == FL_MODULE
 771                 && sym->attr.proc != PROC_MODULE)
 772             || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
 773         && gfc_add_procedure (&sym->attr, PROC_MODULE,
 774                               sym->name, NULL) == FAILURE)
 775     rc = 2;
 776
 777   return rc;
 778 }
 779
 780
 781 /* Verify that the given symbol representing a parameter is C
 782    interoperable, by checking to see if it was marked as such after
 783    its declaration.  If the given symbol is not interoperable, a
 784    warning is reported, thus removing the need to return the status to
 785    the calling function.  The standard does not require the user use
 786    one of the iso_c_binding named constants to declare an
 787    interoperable parameter, but we can't be sure if the param is C
 788    interop or not if the user doesn't.  For example, integer(4) may be
 789    legal Fortran, but doesn't have meaning in C.  It may interop with
 790    a number of the C types, which causes a problem because the
 791    compiler can't know which one.  This code is almost certainly not
 792    portable, and the user will get what they deserve if the C type
 793    across platforms isn't always interoperable with integer(4).  If
 794    the user had used something like integer(c_int) or integer(c_long),
 795    the compiler could have automatically handled the varying sizes
 796    across platforms.  */
 797
 798 try
 799 verify_c_interop_param (gfc_symbol *sym)
 800 {
 801   int is_c_interop = 0;
 802   try retval = SUCCESS;
 803
 804   /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
 805      Don't repeat the checks here.  */
 806   if (sym->attr.implicit_type)
 807     return SUCCESS;
 808
 809   /* For subroutines or functions that are passed to a BIND(C) procedure,
 810      they're interoperable if they're BIND(C) and their params are all
 811      interoperable.  */
 812   if (sym->attr.flavor == FL_PROCEDURE)
 813     {
 814       if (sym->attr.is_bind_c == 0)
 815         {
 816           gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
 817                          "attribute to be C interoperable", sym->name,
 818                          &(sym->declared_at));
 819
 820           return FAILURE;
 821         }
 822       else
 823         {
 824           if (sym->attr.is_c_interop == 1)
 825             /* We've already checked this procedure; don't check it again.  */
 826             return SUCCESS;
 827           else
 828             return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
 829                                       sym->common_block);
 830         }
 831     }
 832
 833   /* See if we've stored a reference to a procedure that owns sym.  */
 834   if (sym->ns != NULL && sym->ns->proc_name != NULL)
 835     {
 836       if (sym->ns->proc_name->attr.is_bind_c == 1)
 837         {
 838           is_c_interop =
 839             (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
 840              == SUCCESS ? 1 : 0);
 841
 842           if (is_c_interop != 1)
 843             {
 844               /* Make personalized messages to give better feedback.  */
 845               if (sym->ts.type == BT_DERIVED)
 846                 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
 847                            " procedure '%s' but is not C interoperable "
 848                            "because derived type '%s' is not C interoperable",
 849                            sym->name, &(sym->declared_at),
 850                            sym->ns->proc_name->name,
 851                            sym->ts.derived->name);
 852               else
 853                 gfc_warning ("Variable '%s' at %L is a parameter to the "
 854                              "BIND(C) procedure '%s' but may not be C "
 855                              "interoperable",
 856                              sym->name, &(sym->declared_at),
 857                              sym->ns->proc_name->name);
 858             }
 859
 860           /* Character strings are only C interoperable if they have a
 861              length of 1.  */
 862           if (sym->ts.type == BT_CHARACTER)
 863             {
 864               gfc_charlen *cl = sym->ts.cl;
 865               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
 866                   || mpz_cmp_si (cl->length->value.integer, 1) != 0)
 867                 {
 868                   gfc_error ("Character argument '%s' at %L "
 869                              "must be length 1 because "
 870                              "procedure '%s' is BIND(C)",
 871                              sym->name, &sym->declared_at,
 872                              sym->ns->proc_name->name);
 873                   retval = FAILURE;
 874                 }
 875             }
 876
 877           /* We have to make sure that any param to a bind(c) routine does
 878              not have the allocatable, pointer, or optional attributes,
 879              according to J3/04-007, section 5.1.  */
 880           if (sym->attr.allocatable == 1)
 881             {
 882               gfc_error ("Variable '%s' at %L cannot have the "
 883                          "ALLOCATABLE attribute because procedure '%s'"
 884                          " is BIND(C)", sym->name, &(sym->declared_at),
 885                          sym->ns->proc_name->name);
 886               retval = FAILURE;
 887             }
 888
 889           if (sym->attr.pointer == 1)
 890             {
 891               gfc_error ("Variable '%s' at %L cannot have the "
 892                          "POINTER attribute because procedure '%s'"
 893                          " is BIND(C)", sym->name, &(sym->declared_at),
 894                          sym->ns->proc_name->name);
 895               retval = FAILURE;
 896             }
 897
 898           if (sym->attr.optional == 1)
 899             {
 900               gfc_error ("Variable '%s' at %L cannot have the "
 901                          "OPTIONAL attribute because procedure '%s'"
 902                          " is BIND(C)", sym->name, &(sym->declared_at),
 903                          sym->ns->proc_name->name);
 904               retval = FAILURE;
 905             }
 906
 907           /* Make sure that if it has the dimension attribute, that it is
 908              either assumed size or explicit shape.  */
 909           if (sym->as != NULL)
 910             {
 911               if (sym->as->type == AS_ASSUMED_SHAPE)
 912                 {
 913                   gfc_error ("Assumed-shape array '%s' at %L cannot be an "
 914                              "argument to the procedure '%s' at %L because "
 915                              "the procedure is BIND(C)", sym->name,
 916                              &(sym->declared_at), sym->ns->proc_name->name,
 917                              &(sym->ns->proc_name->declared_at));
 918                   retval = FAILURE;
 919                 }
 920
 921               if (sym->as->type == AS_DEFERRED)
 922                 {
 923                   gfc_error ("Deferred-shape array '%s' at %L cannot be an "
 924                              "argument to the procedure '%s' at %L because "
 925                              "the procedure is BIND(C)", sym->name,
 926                              &(sym->declared_at), sym->ns->proc_name->name,
 927                              &(sym->ns->proc_name->declared_at));
 928                   retval = FAILURE;
 929                 }
 930           }
 931         }
 932     }
 933
 934   return retval;
 935 }
 936
 937
 938 /* Function called by variable_decl() that adds a name to the symbol table.  */
 939
 940 static try
 941 build_sym (const char *name, gfc_charlen *cl,
 942            gfc_array_spec **as, locus *var_locus)
 943 {
 944   symbol_attribute attr;
 945   gfc_symbol *sym;
 946
 947   if (gfc_get_symbol (name, NULL, &sym))
 948     return FAILURE;
 949
 950   /* Start updating the symbol table.  Add basic type attribute if present.  */
 951   if (current_ts.type != BT_UNKNOWN
 952       && (sym->attr.implicit_type == 0
 953           || !gfc_compare_types (&sym->ts, &current_ts))
 954       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
 955     return FAILURE;
 956
 957   if (sym->ts.type == BT_CHARACTER)
 958     sym->ts.cl = cl;
 959
 960   /* Add dimension attribute if present.  */
 961   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
 962     return FAILURE;
 963   *as = NULL;
 964
 965   /* Add attribute to symbol.  The copy is so that we can reset the
 966      dimension attribute.  */
 967   attr = current_attr;
 968   attr.dimension = 0;
 969
 970   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
 971     return FAILURE;
 972
 973   /* Finish any work that may need to be done for the binding label,
 974      if it's a bind(c).  The bind(c) attr is found before the symbol
 975      is made, and before the symbol name (for data decls), so the
 976      current_ts is holding the binding label, or nothing if the
 977      name= attr wasn't given.  Therefore, test here if we're dealing
 978      with a bind(c) and make sure the binding label is set correctly.  */
 979   if (sym->attr.is_bind_c == 1)
 980     {
 981       if (sym->binding_label[0] == '\0')
 982         {
 983           /* Set the binding label and verify that if a NAME= was specified
 984              then only one identifier was in the entity-decl-list.  */
 985           if (set_binding_label (sym->binding_label, sym->name,
 986                                  num_idents_on_line) == FAILURE)
 987             return FAILURE;
 988         }
 989     }
 990
 991   /* See if we know we're in a common block, and if it's a bind(c)
 992      common then we need to make sure we're an interoperable type.  */
 993   if (sym->attr.in_common == 1)
 994     {
 995       /* Test the common block object.  */
 996       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
 997           && sym->ts.is_c_interop != 1)
 998         {
 999           gfc_error_now ("Variable '%s' in common block '%s' at %C "
1000                          "must be declared with a C interoperable "
1001                          "kind since common block '%s' is BIND(C)",
1002                          sym->name, sym->common_block->name,
1003                          sym->common_block->name);
1004           gfc_clear_error ();
1005         }
1006     }
1007
1008   sym->attr.implied_index = 0;
1009
1010   return SUCCESS;
1011 }
1012
1013
1014 /* Set character constant to the given length. The constant will be padded or
1015    truncated.  */
1016
1017 void
1018 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
1019 {
1020   char *s;
1021   int slen;
1022
1023   gcc_assert (expr->expr_type == EXPR_CONSTANT);
1024   gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
1025
1026   slen = expr->value.character.length;
1027   if (len != slen)
1028     {
1029       s = gfc_getmem (len + 1);
1030       memcpy (s, expr->value.character.string, MIN (len, slen));
1031       if (len > slen)
1032         memset (&s[slen], ' ', len - slen);
1033
1034       if (gfc_option.warn_character_truncation && slen > len)
1035         gfc_warning_now ("CHARACTER expression at %L is being truncated "
1036                          "(%d/%d)", &expr->where, slen, len);
1037
1038       /* Apply the standard by 'hand' otherwise it gets cleared for
1039          initializers.  */
1040       if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
1041         gfc_error_now ("The CHARACTER elements of the array constructor "
1042                        "at %L must have the same length (%d/%d)",
1043                         &expr->where, slen, len);
1044
1045       s[len] = '\0';
1046       gfc_free (expr->value.character.string);
1047       expr->value.character.string = s;
1048       expr->value.character.length = len;
1049     }
1050 }
1051
1052
1053 /* Function to create and update the enumerator history
1054    using the information passed as arguments.
1055    Pointer "max_enum" is also updated, to point to
1056    enum history node containing largest initializer.
1057
1058    SYM points to the symbol node of enumerator.
1059    INIT points to its enumerator value.  */
1060
1061 static void
1062 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1063 {
1064   enumerator_history *new_enum_history;
1065   gcc_assert (sym != NULL && init != NULL);
1066
1067   new_enum_history = gfc_getmem (sizeof (enumerator_history));
1068
1069   new_enum_history->sym = sym;
1070   new_enum_history->initializer = init;
1071   new_enum_history->next = NULL;
1072
1073   if (enum_history == NULL)
1074     {
1075       enum_history = new_enum_history;
1076       max_enum = enum_history;
1077     }
1078   else
1079     {
1080       new_enum_history->next = enum_history;
1081       enum_history = new_enum_history;
1082
1083       if (mpz_cmp (max_enum->initializer->value.integer,
1084                    new_enum_history->initializer->value.integer) < 0)
1085         max_enum = new_enum_history;
1086     }
1087 }
1088
1089
1090 /* Function to free enum kind history.  */
1091
1092 void
1093 gfc_free_enum_history (void)
1094 {
1095   enumerator_history *current = enum_history;
1096   enumerator_history *next;
1097
1098   while (current != NULL)
1099     {
1100       next = current->next;
1101       gfc_free (current);
1102       current = next;
1103     }
1104   max_enum = NULL;
1105   enum_history = NULL;
1106 }
1107
1108
1109 /* Function called by variable_decl() that adds an initialization
1110    expression to a symbol.  */
1111
1112 static try
1113 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1114 {
1115   symbol_attribute attr;
1116   gfc_symbol *sym;
1117   gfc_expr *init;
1118
1119   init = *initp;
1120   if (find_special (name, &sym))
1121     return FAILURE;
1122
1123   attr = sym->attr;
1124
1125   /* If this symbol is confirming an implicit parameter type,
1126      then an initialization expression is not allowed.  */
1127   if (attr.flavor == FL_PARAMETER
1128       && sym->value != NULL
1129       && *initp != NULL)
1130     {
1131       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1132                  sym->name);
1133       return FAILURE;
1134     }
1135
1136   if (attr.in_common
1137       && !attr.data
1138       && *initp != NULL)
1139     {
1140       gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1141                  sym->name);
1142       return FAILURE;
1143     }
1144
1145   if (init == NULL)
1146     {
1147       /* An initializer is required for PARAMETER declarations.  */
1148       if (attr.flavor == FL_PARAMETER)
1149         {
1150           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1151           return FAILURE;
1152         }
1153     }
1154   else
1155     {
1156       /* If a variable appears in a DATA block, it cannot have an
1157          initializer.  */
1158       if (sym->attr.data)
1159         {
1160           gfc_error ("Variable '%s' at %C with an initializer already "
1161                      "appears in a DATA statement", sym->name);
1162           return FAILURE;
1163         }
1164
1165       /* Check if the assignment can happen. This has to be put off
1166          until later for a derived type variable.  */
1167       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1168           && gfc_check_assign_symbol (sym, init) == FAILURE)
1169         return FAILURE;
1170
1171       if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1172         {
1173           /* Update symbol character length according initializer.  */
1174           if (sym->ts.cl->length == NULL)
1175             {
1176               int clen;
1177               /* If there are multiple CHARACTER variables declared on the
1178                  same line, we don't want them to share the same length.  */
1179               sym->ts.cl = gfc_get_charlen ();
1180               sym->ts.cl->next = gfc_current_ns->cl_list;
1181               gfc_current_ns->cl_list = sym->ts.cl;
1182
1183               if (sym->attr.flavor == FL_PARAMETER)
1184                 {
1185                   if (init->expr_type == EXPR_CONSTANT)
1186                     {
1187                       clen = init->value.character.length;
1188                       sym->ts.cl->length = gfc_int_expr (clen);
1189                     }
1190                   else if (init->expr_type == EXPR_ARRAY)
1191                     {
1192                       gfc_expr *p = init->value.constructor->expr;
1193                       clen = p->value.character.length;
1194                       sym->ts.cl->length = gfc_int_expr (clen);
1195                     }
1196                   else if (init->ts.cl && init->ts.cl->length)
1197                     sym->ts.cl->length =
1198                                 gfc_copy_expr (sym->value->ts.cl->length);
1199                 }
1200             }
1201           /* Update initializer character length according symbol.  */
1202           else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1203             {
1204               int len = mpz_get_si (sym->ts.cl->length->value.integer);
1205               gfc_constructor * p;
1206
1207               if (init->expr_type == EXPR_CONSTANT)
1208                 gfc_set_constant_character_len (len, init, false);
1209               else if (init->expr_type == EXPR_ARRAY)
1210                 {
1211                   /* Build a new charlen to prevent simplification from
1212                      deleting the length before it is resolved.  */
1213                   init->ts.cl = gfc_get_charlen ();
1214                   init->ts.cl->next = gfc_current_ns->cl_list;
1215                   gfc_current_ns->cl_list = sym->ts.cl;
1216                   init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
1217
1218                   for (p = init->value.constructor; p; p = p->next)
1219                     gfc_set_constant_character_len (len, p->expr, false);
1220                 }
1221             }
1222         }
1223
1224       /* Need to check if the expression we initialized this
1225          to was one of the iso_c_binding named constants.  If so,
1226          and we're a parameter (constant), let it be iso_c.
1227          For example:
1228          integer(c_int), parameter :: my_int = c_int
1229          integer(my_int) :: my_int_2
1230          If we mark my_int as iso_c (since we can see it's value
1231          is equal to one of the named constants), then my_int_2
1232          will be considered C interoperable.  */
1233       if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1234         {
1235           sym->ts.is_iso_c |= init->ts.is_iso_c;
1236           sym->ts.is_c_interop |= init->ts.is_c_interop;
1237           /* attr bits needed for module files.  */
1238           sym->attr.is_iso_c |= init->ts.is_iso_c;
1239           sym->attr.is_c_interop |= init->ts.is_c_interop;
1240           if (init->ts.is_iso_c)
1241             sym->ts.f90_type = init->ts.f90_type;
1242         }
1243
1244       /* Add initializer.  Make sure we keep the ranks sane.  */
1245       if (sym->attr.dimension && init->rank == 0)
1246         {
1247           mpz_t size;
1248           gfc_expr *array;
1249           gfc_constructor *c;
1250           int n;
1251           if (sym->attr.flavor == FL_PARAMETER
1252                 && init->expr_type == EXPR_CONSTANT
1253                 && spec_size (sym->as, &size) == SUCCESS
1254                 && mpz_cmp_si (size, 0) > 0)
1255             {
1256               array = gfc_start_constructor (init->ts.type, init->ts.kind,
1257                                              &init->where);
1258
1259               array->value.constructor = c = NULL;
1260               for (n = 0; n < (int)mpz_get_si (size); n++)
1261                 {
1262                   if (array->value.constructor == NULL)
1263                     {
1264                       array->value.constructor = c = gfc_get_constructor ();
1265                       c->expr = init;
1266                     }
1267                   else
1268                     {
1269                       c->next = gfc_get_constructor ();
1270                       c = c->next;
1271                       c->expr = gfc_copy_expr (init);
1272                     }
1273                 }
1274
1275               array->shape = gfc_get_shape (sym->as->rank);
1276               for (n = 0; n < sym->as->rank; n++)
1277                 spec_dimen_size (sym->as, n, &array->shape[n]);
1278
1279               init = array;
1280               mpz_clear (size);
1281             }
1282           init->rank = sym->as->rank;
1283         }
1284
1285       sym->value = init;
1286       if (sym->attr.save == SAVE_NONE)
1287         sym->attr.save = SAVE_IMPLICIT;
1288       *initp = NULL;
1289     }
1290
1291   return SUCCESS;
1292 }
1293
1294
1295 /* Function called by variable_decl() that adds a name to a structure
1296    being built.  */
1297
1298 static try
1299 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1300               gfc_array_spec **as)
1301 {
1302   gfc_component *c;
1303
1304   /* If the current symbol is of the same derived type that we're
1305      constructing, it must have the pointer attribute.  */
1306   if (current_ts.type == BT_DERIVED
1307       && current_ts.derived == gfc_current_block ()
1308       && current_attr.pointer == 0)
1309     {
1310       gfc_error ("Component at %C must have the POINTER attribute");
1311       return FAILURE;
1312     }
1313
1314   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1315     {
1316       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1317         {
1318           gfc_error ("Array component of structure at %C must have explicit "
1319                      "or deferred shape");
1320           return FAILURE;
1321         }
1322     }
1323
1324   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1325     return FAILURE;
1326
1327   c->ts = current_ts;
1328   c->ts.cl = cl;
1329   gfc_set_component_attr (c, &current_attr);
1330
1331   c->initializer = *init;
1332   *init = NULL;
1333
1334   c->as = *as;
1335   if (c->as != NULL)
1336     c->dimension = 1;
1337   *as = NULL;
1338
1339   /* Check array components.  */
1340   if (!c->dimension)
1341     {
1342       if (c->allocatable)
1343         {
1344           gfc_error ("Allocatable component at %C must be an array");
1345           return FAILURE;
1346         }
1347       else
1348         return SUCCESS;
1349     }
1350
1351   if (c->pointer)
1352     {
1353       if (c->as->type != AS_DEFERRED)
1354         {
1355           gfc_error ("Pointer array component of structure at %C must have a "
1356                      "deferred shape");
1357           return FAILURE;
1358         }
1359     }
1360   else if (c->allocatable)
1361     {
1362       if (c->as->type != AS_DEFERRED)
1363         {
1364           gfc_error ("Allocatable component of structure at %C must have a "
1365                      "deferred shape");
1366           return FAILURE;
1367         }
1368     }
1369   else
1370     {
1371       if (c->as->type != AS_EXPLICIT)
1372         {
1373           gfc_error ("Array component of structure at %C must have an "
1374                      "explicit shape");
1375           return FAILURE;
1376         }
1377     }
1378
1379   return SUCCESS;
1380 }
1381
1382
1383 /* Match a 'NULL()', and possibly take care of some side effects.  */
1384
1385 match
1386 gfc_match_null (gfc_expr **result)
1387 {
1388   gfc_symbol *sym;
1389   gfc_expr *e;
1390   match m;
1391
1392   m = gfc_match (" null ( )");
1393   if (m != MATCH_YES)
1394     return m;
1395
1396   /* The NULL symbol now has to be/become an intrinsic function.  */
1397   if (gfc_get_symbol ("null", NULL, &sym))
1398     {
1399       gfc_error ("NULL() initialization at %C is ambiguous");
1400       return MATCH_ERROR;
1401     }
1402
1403   gfc_intrinsic_symbol (sym);
1404
1405   if (sym->attr.proc != PROC_INTRINSIC
1406       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1407                              sym->name, NULL) == FAILURE
1408           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1409     return MATCH_ERROR;
1410
1411   e = gfc_get_expr ();
1412   e->where = gfc_current_locus;
1413   e->expr_type = EXPR_NULL;
1414   e->ts.type = BT_UNKNOWN;
1415
1416   *result = e;
1417
1418   return MATCH_YES;
1419 }
1420
1421
1422 /* Match a variable name with an optional initializer.  When this
1423    subroutine is called, a variable is expected to be parsed next.
1424    Depending on what is happening at the moment, updates either the
1425    symbol table or the current interface.  */
1426
1427 static match
1428 variable_decl (int elem)
1429 {
1430   char name[GFC_MAX_SYMBOL_LEN + 1];
1431   gfc_expr *initializer, *char_len;
1432   gfc_array_spec *as;
1433   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1434   gfc_charlen *cl;
1435   locus var_locus;
1436   match m;
1437   try t;
1438   gfc_symbol *sym;
1439   locus old_locus;
1440
1441   initializer = NULL;
1442   as = NULL;
1443   cp_as = NULL;
1444   old_locus = gfc_current_locus;
1445
1446   /* When we get here, we've just matched a list of attributes and
1447      maybe a type and a double colon.  The next thing we expect to see
1448      is the name of the symbol.  */
1449   m = gfc_match_name (name);
1450   if (m != MATCH_YES)
1451     goto cleanup;
1452
1453   var_locus = gfc_current_locus;
1454
1455   /* Now we could see the optional array spec. or character length.  */
1456   m = gfc_match_array_spec (&as);
1457   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1458     cp_as = gfc_copy_array_spec (as);
1459   else if (m == MATCH_ERROR)
1460     goto cleanup;
1461
1462   if (m == MATCH_NO)
1463     as = gfc_copy_array_spec (current_as);
1464
1465   char_len = NULL;
1466   cl = NULL;
1467
1468   if (current_ts.type == BT_CHARACTER)
1469     {
1470       switch (match_char_length (&char_len))
1471         {
1472         case MATCH_YES:
1473           cl = gfc_get_charlen ();
1474           cl->next = gfc_current_ns->cl_list;
1475           gfc_current_ns->cl_list = cl;
1476
1477           cl->length = char_len;
1478           break;
1479
1480         /* Non-constant lengths need to be copied after the first
1481            element.  Also copy assumed lengths.  */
1482         case MATCH_NO:
1483           if (elem > 1
1484               && (current_ts.cl->length == NULL
1485                   || current_ts.cl->length->expr_type != EXPR_CONSTANT))
1486             {
1487               cl = gfc_get_charlen ();
1488               cl->next = gfc_current_ns->cl_list;
1489               gfc_current_ns->cl_list = cl;
1490               cl->length = gfc_copy_expr (current_ts.cl->length);
1491             }
1492           else
1493             cl = current_ts.cl;
1494
1495           break;
1496
1497         case MATCH_ERROR:
1498           goto cleanup;
1499         }
1500     }
1501
1502   /*  If this symbol has already shown up in a Cray Pointer declaration,
1503       then we want to set the type & bail out.  */
1504   if (gfc_option.flag_cray_pointer)
1505     {
1506       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1507       if (sym != NULL && sym->attr.cray_pointee)
1508         {
1509           sym->ts.type = current_ts.type;
1510           sym->ts.kind = current_ts.kind;
1511           sym->ts.cl = cl;
1512           sym->ts.derived = current_ts.derived;
1513           sym->ts.is_c_interop = current_ts.is_c_interop;
1514           sym->ts.is_iso_c = current_ts.is_iso_c;
1515           m = MATCH_YES;
1516
1517           /* Check to see if we have an array specification.  */
1518           if (cp_as != NULL)
1519             {
1520               if (sym->as != NULL)
1521                 {
1522                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1523                   gfc_free_array_spec (cp_as);
1524                   m = MATCH_ERROR;
1525                   goto cleanup;
1526                 }
1527               else
1528                 {
1529                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1530                     gfc_internal_error ("Couldn't set pointee array spec.");
1531
1532                   /* Fix the array spec.  */
1533                   m = gfc_mod_pointee_as (sym->as);
1534                   if (m == MATCH_ERROR)
1535                     goto cleanup;
1536                 }
1537             }
1538           goto cleanup;
1539         }
1540       else
1541         {
1542           gfc_free_array_spec (cp_as);
1543         }
1544     }
1545
1546
1547   /* OK, we've successfully matched the declaration.  Now put the
1548      symbol in the current namespace, because it might be used in the
1549      optional initialization expression for this symbol, e.g. this is
1550      perfectly legal:
1551
1552      integer, parameter :: i = huge(i)
1553
1554      This is only true for parameters or variables of a basic type.
1555      For components of derived types, it is not true, so we don't
1556      create a symbol for those yet.  If we fail to create the symbol,
1557      bail out.  */
1558   if (gfc_current_state () != COMP_DERIVED
1559       && build_sym (name, cl, &as, &var_locus) == FAILURE)
1560     {
1561       m = MATCH_ERROR;
1562       goto cleanup;
1563     }
1564
1565   /* An interface body specifies all of the procedure's
1566      characteristics and these shall be consistent with those
1567      specified in the procedure definition, except that the interface
1568      may specify a procedure that is not pure if the procedure is
1569      defined to be pure(12.3.2).  */
1570   if (current_ts.type == BT_DERIVED
1571       && gfc_current_ns->proc_name
1572       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1573       && current_ts.derived->ns != gfc_current_ns)
1574     {
1575       gfc_symtree *st;
1576       st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
1577       if (!(current_ts.derived->attr.imported
1578                 && st != NULL
1579                 && st->n.sym == current_ts.derived)
1580             && !gfc_current_ns->has_import_set)
1581         {
1582             gfc_error ("the type of '%s' at %C has not been declared within the "
1583                        "interface", name);
1584             m = MATCH_ERROR;
1585             goto cleanup;
1586         }
1587     }
1588
1589   /* In functions that have a RESULT variable defined, the function
1590      name always refers to function calls.  Therefore, the name is
1591      not allowed to appear in specification statements.  */
1592   if (gfc_current_state () == COMP_FUNCTION
1593       && gfc_current_block () != NULL
1594       && gfc_current_block ()->result != NULL
1595       && gfc_current_block ()->result != gfc_current_block ()
1596       && strcmp (gfc_current_block ()->name, name) == 0)
1597     {
1598       gfc_error ("Function name '%s' not allowed at %C", name);
1599       m = MATCH_ERROR;
1600       goto cleanup;
1601     }
1602
1603   /* We allow old-style initializations of the form
1604        integer i /2/, j(4) /3*3, 1/
1605      (if no colon has been seen). These are different from data
1606      statements in that initializers are only allowed to apply to the
1607      variable immediately preceding, i.e.
1608        integer i, j /1, 2/
1609      is not allowed. Therefore we have to do some work manually, that
1610      could otherwise be left to the matchers for DATA statements.  */
1611
1612   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1613     {
1614       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1615                           "initialization at %C") == FAILURE)
1616         return MATCH_ERROR;
1617
1618       return match_old_style_init (name);
1619     }
1620
1621   /* The double colon must be present in order to have initializers.
1622      Otherwise the statement is ambiguous with an assignment statement.  */
1623   if (colon_seen)
1624     {
1625       if (gfc_match (" =>") == MATCH_YES)
1626         {
1627           if (!current_attr.pointer)
1628             {
1629               gfc_error ("Initialization at %C isn't for a pointer variable");
1630               m = MATCH_ERROR;
1631               goto cleanup;
1632             }
1633
1634           m = gfc_match_null (&initializer);
1635           if (m == MATCH_NO)
1636             {
1637               gfc_error ("Pointer initialization requires a NULL() at %C");
1638               m = MATCH_ERROR;
1639             }
1640
1641           if (gfc_pure (NULL))
1642             {
1643               gfc_error ("Initialization of pointer at %C is not allowed in "
1644                          "a PURE procedure");
1645               m = MATCH_ERROR;
1646             }
1647
1648           if (m != MATCH_YES)
1649             goto cleanup;
1650
1651         }
1652       else if (gfc_match_char ('=') == MATCH_YES)
1653         {
1654           if (current_attr.pointer)
1655             {
1656               gfc_error ("Pointer initialization at %C requires '=>', "
1657                          "not '='");
1658               m = MATCH_ERROR;
1659               goto cleanup;
1660             }
1661
1662           m = gfc_match_init_expr (&initializer);
1663           if (m == MATCH_NO)
1664             {
1665               gfc_error ("Expected an initialization expression at %C");
1666               m = MATCH_ERROR;
1667             }
1668
1669           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1670             {
1671               gfc_error ("Initialization of variable at %C is not allowed in "
1672                          "a PURE procedure");
1673               m = MATCH_ERROR;
1674             }
1675
1676           if (m != MATCH_YES)
1677             goto cleanup;
1678         }
1679     }
1680
1681   if (initializer != NULL && current_attr.allocatable
1682         && gfc_current_state () == COMP_DERIVED)
1683     {
1684       gfc_error ("Initialization of allocatable component at %C is not "
1685                  "allowed");
1686       m = MATCH_ERROR;
1687       goto cleanup;
1688     }
1689
1690   /* Add the initializer.  Note that it is fine if initializer is
1691      NULL here, because we sometimes also need to check if a
1692      declaration *must* have an initialization expression.  */
1693   if (gfc_current_state () != COMP_DERIVED)
1694     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1695   else
1696     {
1697       if (current_ts.type == BT_DERIVED
1698           && !current_attr.pointer && !initializer)
1699         initializer = gfc_default_initializer (&current_ts);
1700       t = build_struct (name, cl, &initializer, &as);
1701     }
1702
1703   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1704
1705 cleanup:
1706   /* Free stuff up and return.  */
1707   gfc_free_expr (initializer);
1708   gfc_free_array_spec (as);
1709
1710   return m;
1711 }
1712
1713
1714 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1715    This assumes that the byte size is equal to the kind number for
1716    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
1717
1718 match
1719 gfc_match_old_kind_spec (gfc_typespec *ts)
1720 {
1721   match m;
1722   int original_kind;
1723
1724   if (gfc_match_char ('*') != MATCH_YES)
1725     return MATCH_NO;
1726
1727   m = gfc_match_small_literal_int (&ts->kind, NULL);
1728   if (m != MATCH_YES)
1729     return MATCH_ERROR;
1730
1731   original_kind = ts->kind;
1732
1733   /* Massage the kind numbers for complex types.  */
1734   if (ts->type == BT_COMPLEX)
1735     {
1736       if (ts->kind % 2)
1737         {
1738           gfc_error ("Old-style type declaration %s*%d not supported at %C",
1739                      gfc_basic_typename (ts->type), original_kind);
1740           return MATCH_ERROR;
1741         }
1742       ts->kind /= 2;
1743     }
1744
1745   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1746     {
1747       gfc_error ("Old-style type declaration %s*%d not supported at %C",
1748                  gfc_basic_typename (ts->type), original_kind);
1749       return MATCH_ERROR;
1750     }
1751
1752   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1753                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
1754     return MATCH_ERROR;
1755
1756   return MATCH_YES;
1757 }
1758
1759
1760 /* Match a kind specification.  Since kinds are generally optional, we
1761    usually return MATCH_NO if something goes wrong.  If a "kind="
1762    string is found, then we know we have an error.  */
1763
1764 match
1765 gfc_match_kind_spec (gfc_typespec *ts)
1766 {
1767   locus where;
1768   gfc_expr *e;
1769   match m, n;
1770   const char *msg;
1771
1772   m = MATCH_NO;
1773   e = NULL;
1774
1775   where = gfc_current_locus;
1776
1777   if (gfc_match_char ('(') == MATCH_NO)
1778     return MATCH_NO;
1779
1780   /* Also gobbles optional text.  */
1781   if (gfc_match (" kind = ") == MATCH_YES)
1782     m = MATCH_ERROR;
1783
1784   n = gfc_match_init_expr (&e);
1785   if (n == MATCH_NO)
1786     gfc_error ("Expected initialization expression at %C");
1787   if (n != MATCH_YES)
1788     return MATCH_ERROR;
1789
1790   if (e->rank != 0)
1791     {
1792       gfc_error ("Expected scalar initialization expression at %C");
1793       m = MATCH_ERROR;
1794       goto no_match;
1795     }
1796
1797   msg = gfc_extract_int (e, &ts->kind);
1798   if (msg != NULL)
1799     {
1800       gfc_error (msg);
1801       m = MATCH_ERROR;
1802       goto no_match;
1803     }
1804
1805   /* Before throwing away the expression, let's see if we had a
1806      C interoperable kind (and store the fact).  */
1807   if (e->ts.is_c_interop == 1)
1808     {
1809       /* Mark this as c interoperable if being declared with one
1810          of the named constants from iso_c_binding.  */
1811       ts->is_c_interop = e->ts.is_iso_c;
1812       ts->f90_type = e->ts.f90_type;
1813     }
1814
1815   gfc_free_expr (e);
1816   e = NULL;
1817
1818   /* Ignore errors to this point, if we've gotten here.  This means
1819      we ignore the m=MATCH_ERROR from above.  */
1820   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1821     {
1822       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1823                  gfc_basic_typename (ts->type));
1824       m = MATCH_ERROR;
1825     }
1826   else if (gfc_match_char (')') != MATCH_YES)
1827     {
1828       gfc_error ("Missing right parenthesis at %C");
1829      m = MATCH_ERROR;
1830     }
1831   else
1832      /* All tests passed.  */
1833      m = MATCH_YES;
1834
1835   if(m == MATCH_ERROR)
1836      gfc_current_locus = where;
1837
1838   /* Return what we know from the test(s).  */
1839   return m;
1840
1841 no_match:
1842   gfc_free_expr (e);
1843   gfc_current_locus = where;
1844   return m;
1845 }
1846
1847
1848 /* Match the various kind/length specifications in a CHARACTER
1849    declaration.  We don't return MATCH_NO.  */
1850
1851 static match
1852 match_char_spec (gfc_typespec *ts)
1853 {
1854   int kind, seen_length;
1855   gfc_charlen *cl;
1856   gfc_expr *len;
1857   match m;
1858   gfc_expr *kind_expr = NULL;
1859   kind = gfc_default_character_kind;
1860   len = NULL;
1861   seen_length = 0;
1862
1863   /* Try the old-style specification first.  */
1864   old_char_selector = 0;
1865
1866   m = match_char_length (&len);
1867   if (m != MATCH_NO)
1868     {
1869       if (m == MATCH_YES)
1870         old_char_selector = 1;
1871       seen_length = 1;
1872       goto done;
1873     }
1874
1875   m = gfc_match_char ('(');
1876   if (m != MATCH_YES)
1877     {
1878       m = MATCH_YES;    /* Character without length is a single char.  */
1879       goto done;
1880     }
1881
1882   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
1883   if (gfc_match (" kind =") == MATCH_YES)
1884     {
1885       m = gfc_match_small_int_expr(&kind, &kind_expr);
1886
1887       if (m == MATCH_ERROR)
1888         goto done;
1889       if (m == MATCH_NO)
1890         goto syntax;
1891
1892       if (gfc_match (" , len =") == MATCH_NO)
1893         goto rparen;
1894
1895       m = char_len_param_value (&len);
1896       if (m == MATCH_NO)
1897         goto syntax;
1898       if (m == MATCH_ERROR)
1899         goto done;
1900       seen_length = 1;
1901
1902       goto rparen;
1903     }
1904
1905   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
1906   if (gfc_match (" len =") == MATCH_YES)
1907     {
1908       m = char_len_param_value (&len);
1909       if (m == MATCH_NO)
1910         goto syntax;
1911       if (m == MATCH_ERROR)
1912         goto done;
1913       seen_length = 1;
1914
1915       if (gfc_match_char (')') == MATCH_YES)
1916         goto done;
1917
1918       if (gfc_match (" , kind =") != MATCH_YES)
1919         goto syntax;
1920
1921       gfc_match_small_int_expr(&kind, &kind_expr);
1922
1923       if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1924         {
1925           gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1926           return MATCH_YES;
1927         }
1928
1929       goto rparen;
1930     }
1931
1932   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
1933   m = char_len_param_value (&len);
1934   if (m == MATCH_NO)
1935     goto syntax;
1936   if (m == MATCH_ERROR)
1937     goto done;
1938   seen_length = 1;
1939
1940   m = gfc_match_char (')');
1941   if (m == MATCH_YES)
1942     goto done;
1943
1944   if (gfc_match_char (',') != MATCH_YES)
1945     goto syntax;
1946
1947   gfc_match (" kind =");        /* Gobble optional text.  */
1948
1949   m = gfc_match_small_int_expr(&kind, &kind_expr);
1950   if (m == MATCH_ERROR)
1951     goto done;
1952   if (m == MATCH_NO)
1953     goto syntax;
1954
1955 rparen:
1956   /* Require a right-paren at this point.  */
1957   m = gfc_match_char (')');
1958   if (m == MATCH_YES)
1959     goto done;
1960
1961 syntax:
1962   gfc_error ("Syntax error in CHARACTER declaration at %C");
1963   m = MATCH_ERROR;
1964   gfc_free_expr (len);
1965   return m;
1966
1967 done:
1968   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1969     {
1970       gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1971       m = MATCH_ERROR;
1972     }
1973
1974   if (seen_length == 1 && len != NULL
1975       && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN)
1976     {
1977       gfc_error ("Expression at %C must be of INTEGER type");
1978       m = MATCH_ERROR;
1979     }
1980
1981   if (m != MATCH_YES)
1982     {
1983       gfc_free_expr (len);
1984       gfc_free_expr (kind_expr);
1985       return m;
1986     }
1987
1988   /* Do some final massaging of the length values.  */
1989   cl = gfc_get_charlen ();
1990   cl->next = gfc_current_ns->cl_list;
1991   gfc_current_ns->cl_list = cl;
1992
1993   if (seen_length == 0)
1994     cl->length = gfc_int_expr (1);
1995   else
1996     cl->length = len;
1997
1998   ts->cl = cl;
1999   ts->kind = kind;
2000
2001   /* We have to know if it was a c interoperable kind so we can
2002      do accurate type checking of bind(c) procs, etc.  */
2003   if (kind_expr != NULL)
2004     {
2005       /* Mark this as c interoperable if being declared with one
2006          of the named constants from iso_c_binding.  */
2007       ts->is_c_interop = kind_expr->ts.is_iso_c;
2008       gfc_free_expr (kind_expr);
2009     }
2010   else if (len != NULL)
2011     {
2012       /* Here, we might have parsed something such as:
2013          character(c_char)
2014          In this case, the parsing code above grabs the c_char when
2015          looking for the length (line 1690, roughly).  it's the last
2016          testcase for parsing the kind params of a character variable.
2017          However, it's not actually the length.  this seems like it
2018          could be an error.
2019          To see if the user used a C interop kind, test the expr
2020          of the so called length, and see if it's C interoperable.  */
2021       ts->is_c_interop = len->ts.is_iso_c;
2022     }
2023
2024   return MATCH_YES;
2025 }
2026
2027
2028 /* Matches a type specification.  If successful, sets the ts structure
2029    to the matched specification.  This is necessary for FUNCTION and
2030    IMPLICIT statements.
2031
2032    If implicit_flag is nonzero, then we don't check for the optional
2033    kind specification.  Not doing so is needed for matching an IMPLICIT
2034    statement correctly.  */
2035
2036 static match
2037 match_type_spec (gfc_typespec *ts, int implicit_flag)
2038 {
2039   char name[GFC_MAX_SYMBOL_LEN + 1];
2040   gfc_symbol *sym;
2041   match m;
2042   int c;
2043
2044   gfc_clear_ts (ts);
2045
2046   /* Clear the current binding label, in case one is given.  */
2047   curr_binding_label[0] = '\0';
2048
2049   if (gfc_match (" byte") == MATCH_YES)
2050     {
2051       if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
2052           == FAILURE)
2053         return MATCH_ERROR;
2054
2055       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2056         {
2057           gfc_error ("BYTE type used at %C "
2058                      "is not available on the target machine");
2059           return MATCH_ERROR;
2060         }
2061
2062       ts->type = BT_INTEGER;
2063       ts->kind = 1;
2064       return MATCH_YES;
2065     }
2066
2067   if (gfc_match (" integer") == MATCH_YES)
2068     {
2069       ts->type = BT_INTEGER;
2070       ts->kind = gfc_default_integer_kind;
2071       goto get_kind;
2072     }
2073
2074   if (gfc_match (" character") == MATCH_YES)
2075     {
2076       ts->type = BT_CHARACTER;
2077       if (implicit_flag == 0)
2078         return match_char_spec (ts);
2079       else
2080         return MATCH_YES;
2081     }
2082
2083   if (gfc_match (" real") == MATCH_YES)
2084     {
2085       ts->type = BT_REAL;
2086       ts->kind = gfc_default_real_kind;
2087       goto get_kind;
2088     }
2089
2090   if (gfc_match (" double precision") == MATCH_YES)
2091     {
2092       ts->type = BT_REAL;
2093       ts->kind = gfc_default_double_kind;
2094       return MATCH_YES;
2095     }
2096
2097   if (gfc_match (" complex") == MATCH_YES)
2098     {
2099       ts->type = BT_COMPLEX;
2100       ts->kind = gfc_default_complex_kind;
2101       goto get_kind;
2102     }
2103
2104   if (gfc_match (" double complex") == MATCH_YES)
2105     {
2106       if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2107                           "conform to the Fortran 95 standard") == FAILURE)
2108         return MATCH_ERROR;
2109
2110       ts->type = BT_COMPLEX;
2111       ts->kind = gfc_default_double_kind;
2112       return MATCH_YES;
2113     }
2114
2115   if (gfc_match (" logical") == MATCH_YES)
2116     {
2117       ts->type = BT_LOGICAL;
2118       ts->kind = gfc_default_logical_kind;
2119       goto get_kind;
2120     }
2121
2122   m = gfc_match (" type ( %n )", name);
2123   if (m != MATCH_YES)
2124     return m;
2125
2126   /* Search for the name but allow the components to be defined later.  */
2127   if (gfc_get_ha_symbol (name, &sym))
2128     {
2129       gfc_error ("Type name '%s' at %C is ambiguous", name);
2130       return MATCH_ERROR;
2131     }
2132
2133   if (sym->attr.flavor != FL_DERIVED
2134       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2135     return MATCH_ERROR;
2136
2137   ts->type = BT_DERIVED;
2138   ts->kind = 0;
2139   ts->derived = sym;
2140
2141   return MATCH_YES;
2142
2143 get_kind:
2144   /* For all types except double, derived and character, look for an
2145      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2146   if (implicit_flag == 1)
2147     return MATCH_YES;
2148
2149   if (gfc_current_form == FORM_FREE)
2150     {
2151       c = gfc_peek_char();
2152       if (!gfc_is_whitespace(c) && c != '*' && c != '('
2153           && c != ':' && c != ',')
2154        return MATCH_NO;
2155     }
2156
2157   m = gfc_match_kind_spec (ts);
2158   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2159     m = gfc_match_old_kind_spec (ts);
2160
2161   if (m == MATCH_NO)
2162     m = MATCH_YES;              /* No kind specifier found.  */
2163
2164   return m;
2165 }
2166
2167
2168 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2169    already matched in parse.c, or we would not end up here in the
2170    first place.  So the only thing we need to check, is if there is
2171    trailing garbage.  If not, the match is successful.  */
2172
2173 match
2174 gfc_match_implicit_none (void)
2175 {
2176   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2177 }
2178
2179
2180 /* Match the letter range(s) of an IMPLICIT statement.  */
2181
2182 static match
2183 match_implicit_range (void)
2184 {
2185   int c, c1, c2, inner;
2186   locus cur_loc;
2187
2188   cur_loc = gfc_current_locus;
2189
2190   gfc_gobble_whitespace ();
2191   c = gfc_next_char ();
2192   if (c != '(')
2193     {
2194       gfc_error ("Missing character range in IMPLICIT at %C");
2195       goto bad;
2196     }
2197
2198   inner = 1;
2199   while (inner)
2200     {
2201       gfc_gobble_whitespace ();
2202       c1 = gfc_next_char ();
2203       if (!ISALPHA (c1))
2204         goto bad;
2205
2206       gfc_gobble_whitespace ();
2207       c = gfc_next_char ();
2208
2209       switch (c)
2210         {
2211         case ')':
2212           inner = 0;            /* Fall through.  */
2213
2214         case ',':
2215           c2 = c1;
2216           break;
2217
2218         case '-':
2219           gfc_gobble_whitespace ();
2220           c2 = gfc_next_char ();
2221           if (!ISALPHA (c2))
2222             goto bad;
2223
2224           gfc_gobble_whitespace ();
2225           c = gfc_next_char ();
2226
2227           if ((c != ',') && (c != ')'))
2228             goto bad;
2229           if (c == ')')
2230             inner = 0;
2231
2232           break;
2233
2234         default:
2235           goto bad;
2236         }
2237
2238       if (c1 > c2)
2239         {
2240           gfc_error ("Letters must be in alphabetic order in "
2241                      "IMPLICIT statement at %C");
2242           goto bad;
2243         }
2244
2245       /* See if we can add the newly matched range to the pending
2246          implicits from this IMPLICIT statement.  We do not check for
2247          conflicts with whatever earlier IMPLICIT statements may have
2248          set.  This is done when we've successfully finished matching
2249          the current one.  */
2250       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2251         goto bad;
2252     }
2253
2254   return MATCH_YES;
2255
2256 bad:
2257   gfc_syntax_error (ST_IMPLICIT);
2258
2259   gfc_current_locus = cur_loc;
2260   return MATCH_ERROR;
2261 }
2262
2263
2264 /* Match an IMPLICIT statement, storing the types for
2265    gfc_set_implicit() if the statement is accepted by the parser.
2266    There is a strange looking, but legal syntactic construction
2267    possible.  It looks like:
2268
2269      IMPLICIT INTEGER (a-b) (c-d)
2270
2271    This is legal if "a-b" is a constant expression that happens to
2272    equal one of the legal kinds for integers.  The real problem
2273    happens with an implicit specification that looks like:
2274
2275      IMPLICIT INTEGER (a-b)
2276
2277    In this case, a typespec matcher that is "greedy" (as most of the
2278    matchers are) gobbles the character range as a kindspec, leaving
2279    nothing left.  We therefore have to go a bit more slowly in the
2280    matching process by inhibiting the kindspec checking during
2281    typespec matching and checking for a kind later.  */
2282
2283 match
2284 gfc_match_implicit (void)
2285 {
2286   gfc_typespec ts;
2287   locus cur_loc;
2288   int c;
2289   match m;
2290
2291   /* We don't allow empty implicit statements.  */
2292   if (gfc_match_eos () == MATCH_YES)
2293     {
2294       gfc_error ("Empty IMPLICIT statement at %C");
2295       return MATCH_ERROR;
2296     }
2297
2298   do
2299     {
2300       /* First cleanup.  */
2301       gfc_clear_new_implicit ();
2302
2303       /* A basic type is mandatory here.  */
2304       m = match_type_spec (&ts, 1);
2305       if (m == MATCH_ERROR)
2306         goto error;
2307       if (m == MATCH_NO)
2308         goto syntax;
2309
2310       cur_loc = gfc_current_locus;
2311       m = match_implicit_range ();
2312
2313       if (m == MATCH_YES)
2314         {
2315           /* We may have <TYPE> (<RANGE>).  */
2316           gfc_gobble_whitespace ();
2317           c = gfc_next_char ();
2318           if ((c == '\n') || (c == ','))
2319             {
2320               /* Check for CHARACTER with no length parameter.  */
2321               if (ts.type == BT_CHARACTER && !ts.cl)
2322                 {
2323                   ts.kind = gfc_default_character_kind;
2324                   ts.cl = gfc_get_charlen ();
2325                   ts.cl->next = gfc_current_ns->cl_list;
2326                   gfc_current_ns->cl_list = ts.cl;
2327                   ts.cl->length = gfc_int_expr (1);
2328                 }
2329
2330               /* Record the Successful match.  */
2331               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2332                 return MATCH_ERROR;
2333               continue;
2334             }
2335
2336           gfc_current_locus = cur_loc;
2337         }
2338
2339       /* Discard the (incorrectly) matched range.  */
2340       gfc_clear_new_implicit ();
2341
2342       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2343       if (ts.type == BT_CHARACTER)
2344         m = match_char_spec (&ts);
2345       else
2346         {
2347           m = gfc_match_kind_spec (&ts);
2348           if (m == MATCH_NO)
2349             {
2350               m = gfc_match_old_kind_spec (&ts);
2351               if (m == MATCH_ERROR)
2352                 goto error;
2353               if (m == MATCH_NO)
2354                 goto syntax;
2355             }
2356         }
2357       if (m == MATCH_ERROR)
2358         goto error;
2359
2360       m = match_implicit_range ();
2361       if (m == MATCH_ERROR)
2362         goto error;
2363       if (m == MATCH_NO)
2364         goto syntax;
2365
2366       gfc_gobble_whitespace ();
2367       c = gfc_next_char ();
2368       if ((c != '\n') && (c != ','))
2369         goto syntax;
2370
2371       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2372         return MATCH_ERROR;
2373     }
2374   while (c == ',');
2375
2376   return MATCH_YES;
2377
2378 syntax:
2379   gfc_syntax_error (ST_IMPLICIT);
2380
2381 error:
2382   return MATCH_ERROR;
2383 }
2384
2385
2386 match
2387 gfc_match_import (void)
2388 {
2389   char name[GFC_MAX_SYMBOL_LEN + 1];
2390   match m;
2391   gfc_symbol *sym;
2392   gfc_symtree *st;
2393
2394   if (gfc_current_ns->proc_name == NULL
2395       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2396     {
2397       gfc_error ("IMPORT statement at %C only permitted in "
2398                  "an INTERFACE body");
2399       return MATCH_ERROR;
2400     }
2401
2402   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2403       == FAILURE)
2404     return MATCH_ERROR;
2405
2406   if (gfc_match_eos () == MATCH_YES)
2407     {
2408       /* All host variables should be imported.  */
2409       gfc_current_ns->has_import_set = 1;
2410       return MATCH_YES;
2411     }
2412
2413   if (gfc_match (" ::") == MATCH_YES)
2414     {
2415       if (gfc_match_eos () == MATCH_YES)
2416         {
2417            gfc_error ("Expecting list of named entities at %C");
2418            return MATCH_ERROR;
2419         }
2420     }
2421
2422   for(;;)
2423     {
2424       m = gfc_match (" %n", name);
2425       switch (m)
2426         {
2427         case MATCH_YES:
2428           if (gfc_current_ns->parent !=  NULL
2429               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2430             {
2431                gfc_error ("Type name '%s' at %C is ambiguous", name);
2432                return MATCH_ERROR;
2433             }
2434           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2435                    && gfc_find_symbol (name,
2436                                        gfc_current_ns->proc_name->ns->parent,
2437                                        1, &sym))
2438             {
2439                gfc_error ("Type name '%s' at %C is ambiguous", name);
2440                return MATCH_ERROR;
2441             }
2442
2443           if (sym == NULL)
2444             {
2445               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2446                          "at %C - does not exist.", name);
2447               return MATCH_ERROR;
2448             }
2449
2450           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2451             {
2452               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2453                            "at %C.", name);
2454               goto next_item;
2455             }
2456
2457           st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2458           st->n.sym = sym;
2459           sym->refs++;
2460           sym->attr.imported = 1;
2461
2462           goto next_item;
2463
2464         case MATCH_NO:
2465           break;
2466
2467         case MATCH_ERROR:
2468           return MATCH_ERROR;
2469         }
2470
2471     next_item:
2472       if (gfc_match_eos () == MATCH_YES)
2473         break;
2474       if (gfc_match_char (',') != MATCH_YES)
2475         goto syntax;
2476     }
2477
2478   return MATCH_YES;
2479
2480 syntax:
2481   gfc_error ("Syntax error in IMPORT statement at %C");
2482   return MATCH_ERROR;
2483 }
2484
2485
2486 /* A minimal implementation of gfc_match without whitespace, escape
2487    characters or variable arguments.  Returns true if the next
2488    characters match the TARGET template exactly.  */
2489
2490 static bool
2491 match_string_p (const char *target)
2492 {
2493   const char *p;
2494
2495   for (p = target; *p; p++)
2496     if (gfc_next_char () != *p)
2497       return false;
2498   return true;
2499 }
2500
2501 /* Matches an attribute specification including array specs.  If
2502    successful, leaves the variables current_attr and current_as
2503    holding the specification.  Also sets the colon_seen variable for
2504    later use by matchers associated with initializations.
2505
2506    This subroutine is a little tricky in the sense that we don't know
2507    if we really have an attr-spec until we hit the double colon.
2508    Until that time, we can only return MATCH_NO.  This forces us to
2509    check for duplicate specification at this level.  */
2510
2511 static match
2512 match_attr_spec (void)
2513 {
2514   /* Modifiers that can exist in a type statement.  */
2515   typedef enum
2516   { GFC_DECL_BEGIN = 0,
2517     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2518     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2519     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2520     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2521     DECL_IS_BIND_C, DECL_NONE,
2522     GFC_DECL_END /* Sentinel */
2523   }
2524   decl_types;
2525
2526 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2527 #define NUM_DECL GFC_DECL_END
2528
2529   locus start, seen_at[NUM_DECL];
2530   int seen[NUM_DECL];
2531   decl_types d;
2532   const char *attr;
2533   match m;
2534   try t;
2535
2536   gfc_clear_attr (&current_attr);
2537   start = gfc_current_locus;
2538
2539   current_as = NULL;
2540   colon_seen = 0;
2541
2542   /* See if we get all of the keywords up to the final double colon.  */
2543   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2544     seen[d] = 0;
2545
2546   for (;;)
2547     {
2548       int ch;
2549
2550       d = DECL_NONE;
2551       gfc_gobble_whitespace ();
2552
2553       ch = gfc_next_char ();
2554       if (ch == ':')
2555         {
2556           /* This is the successful exit condition for the loop.  */
2557           if (gfc_next_char () == ':')
2558             break;
2559         }
2560       else if (ch == ',')
2561         {
2562           gfc_gobble_whitespace ();
2563           switch (gfc_peek_char ())
2564             {
2565             case 'a':
2566               if (match_string_p ("allocatable"))
2567                 d = DECL_ALLOCATABLE;
2568               break;
2569
2570             case 'b':
2571               /* Try and match the bind(c).  */
2572               m = gfc_match_bind_c (NULL);
2573               if (m == MATCH_YES)
2574                 d = DECL_IS_BIND_C;
2575               else if (m == MATCH_ERROR)
2576                 goto cleanup;
2577               break;
2578
2579             case 'd':
2580               if (match_string_p ("dimension"))
2581                 d = DECL_DIMENSION;
2582               break;
2583
2584             case 'e':
2585               if (match_string_p ("external"))
2586                 d = DECL_EXTERNAL;
2587               break;
2588
2589             case 'i':
2590               if (match_string_p ("int"))
2591                 {
2592                   ch = gfc_next_char ();
2593                   if (ch == 'e')
2594                     {
2595                       if (match_string_p ("nt"))
2596                         {
2597                           /* Matched "intent".  */
2598                           /* TODO: Call match_intent_spec from here.  */
2599                           if (gfc_match (" ( in out )") == MATCH_YES)
2600                             d = DECL_INOUT;
2601                           else if (gfc_match (" ( in )") == MATCH_YES)
2602                             d = DECL_IN;
2603                           else if (gfc_match (" ( out )") == MATCH_YES)
2604                             d = DECL_OUT;
2605                         }
2606                     }
2607                   else if (ch == 'r')
2608                     {
2609                       if (match_string_p ("insic"))
2610                         {
2611                           /* Matched "intrinsic".  */
2612                           d = DECL_INTRINSIC;
2613                         }
2614                     }
2615                 }
2616               break;
2617
2618             case 'o':
2619               if (match_string_p ("optional"))
2620                 d = DECL_OPTIONAL;
2621               break;
2622
2623             case 'p':
2624               gfc_next_char ();
2625               switch (gfc_next_char ())
2626                 {
2627                 case 'a':
2628                   if (match_string_p ("rameter"))
2629                     {
2630                       /* Matched "parameter".  */
2631                       d = DECL_PARAMETER;
2632                     }
2633                   break;
2634
2635                 case 'o':
2636                   if (match_string_p ("inter"))
2637                     {
2638                       /* Matched "pointer".  */
2639                       d = DECL_POINTER;
2640                     }
2641                   break;
2642
2643                 case 'r':
2644                   ch = gfc_next_char ();
2645                   if (ch == 'i')
2646                     {
2647                       if (match_string_p ("vate"))
2648                         {
2649                           /* Matched "private".  */
2650                           d = DECL_PRIVATE;
2651                         }
2652                     }
2653                   else if (ch == 'o')
2654                     {
2655                       if (match_string_p ("tected"))
2656                         {
2657                           /* Matched "protected".  */
2658                           d = DECL_PROTECTED;
2659                         }
2660                     }
2661                   break;
2662
2663                 case 'u':
2664                   if (match_string_p ("blic"))
2665                     {
2666                       /* Matched "public".  */
2667                       d = DECL_PUBLIC;
2668                     }
2669                   break;
2670                 }
2671               break;
2672
2673             case 's':
2674               if (match_string_p ("save"))
2675                 d = DECL_SAVE;
2676               break;
2677
2678             case 't':
2679               if (match_string_p ("target"))
2680                 d = DECL_TARGET;
2681               break;
2682
2683             case 'v':
2684               gfc_next_char ();
2685               ch = gfc_next_char ();
2686               if (ch == 'a')
2687                 {
2688                   if (match_string_p ("lue"))
2689                     {
2690                       /* Matched "value".  */
2691                       d = DECL_VALUE;
2692                     }
2693                 }
2694               else if (ch == 'o')
2695                 {
2696                   if (match_string_p ("latile"))
2697                     {
2698                       /* Matched "volatile".  */
2699                       d = DECL_VOLATILE;
2700                     }
2701                 }
2702               break;
2703             }
2704         }
2705
2706       /* No double colon and no recognizable decl_type, so assume that
2707          we've been looking at something else the whole time.  */
2708       if (d == DECL_NONE)
2709         {
2710           m = MATCH_NO;
2711           goto cleanup;
2712         }
2713
2714       seen[d]++;
2715       seen_at[d] = gfc_current_locus;
2716
2717       if (d == DECL_DIMENSION)
2718         {
2719           m = gfc_match_array_spec (&current_as);
2720
2721           if (m == MATCH_NO)
2722             {
2723               gfc_error ("Missing dimension specification at %C");
2724               m = MATCH_ERROR;
2725             }
2726
2727           if (m == MATCH_ERROR)
2728             goto cleanup;
2729         }
2730     }
2731
2732   /* Since we've seen a double colon, we have to be looking at an
2733      attr-spec.  This means that we can now issue errors.  */
2734   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2735     if (seen[d] > 1)
2736       {
2737         switch (d)
2738           {
2739           case DECL_ALLOCATABLE:
2740             attr = "ALLOCATABLE";
2741             break;
2742           case DECL_DIMENSION:
2743             attr = "DIMENSION";
2744             break;
2745           case DECL_EXTERNAL:
2746             attr = "EXTERNAL";
2747             break;
2748           case DECL_IN:
2749             attr = "INTENT (IN)";
2750             break;
2751           case DECL_OUT:
2752             attr = "INTENT (OUT)";
2753             break;
2754           case DECL_INOUT:
2755             attr = "INTENT (IN OUT)";
2756             break;
2757           case DECL_INTRINSIC:
2758             attr = "INTRINSIC";
2759             break;
2760           case DECL_OPTIONAL:
2761             attr = "OPTIONAL";
2762             break;
2763           case DECL_PARAMETER:
2764             attr = "PARAMETER";
2765             break;
2766           case DECL_POINTER:
2767             attr = "POINTER";
2768             break;
2769           case DECL_PROTECTED:
2770             attr = "PROTECTED";
2771             break;
2772           case DECL_PRIVATE:
2773             attr = "PRIVATE";
2774             break;
2775           case DECL_PUBLIC:
2776             attr = "PUBLIC";
2777             break;
2778           case DECL_SAVE:
2779             attr = "SAVE";
2780             break;
2781           case DECL_TARGET:
2782             attr = "TARGET";
2783             break;
2784           case DECL_IS_BIND_C:
2785             attr = "IS_BIND_C";
2786             break;
2787           case DECL_VALUE:
2788             attr = "VALUE";
2789             break;
2790           case DECL_VOLATILE:
2791             attr = "VOLATILE";
2792             break;
2793           default:
2794             attr = NULL;        /* This shouldn't happen.  */
2795           }
2796
2797         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2798         m = MATCH_ERROR;
2799         goto cleanup;
2800       }
2801
2802   /* Now that we've dealt with duplicate attributes, add the attributes
2803      to the current attribute.  */
2804   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2805     {
2806       if (seen[d] == 0)
2807         continue;
2808
2809       if (gfc_current_state () == COMP_DERIVED
2810           && d != DECL_DIMENSION && d != DECL_POINTER
2811           && d != DECL_PRIVATE   && d != DECL_PUBLIC
2812           && d != DECL_NONE)
2813         {
2814           if (d == DECL_ALLOCATABLE)
2815             {
2816               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2817                                   "attribute at %C in a TYPE definition")
2818                   == FAILURE)
2819                 {
2820                   m = MATCH_ERROR;
2821                   goto cleanup;
2822                 }
2823             }
2824           else
2825             {
2826               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2827                          &seen_at[d]);
2828               m = MATCH_ERROR;
2829               goto cleanup;
2830             }
2831         }
2832
2833       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2834           && gfc_current_state () != COMP_MODULE)
2835         {
2836           if (d == DECL_PRIVATE)
2837             attr = "PRIVATE";
2838           else
2839             attr = "PUBLIC";
2840           if (gfc_current_state () == COMP_DERIVED
2841               && gfc_state_stack->previous
2842               && gfc_state_stack->previous->state == COMP_MODULE)
2843             {
2844               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2845                                   "at %L in a TYPE definition", attr,
2846                                   &seen_at[d])
2847                   == FAILURE)
2848                 {
2849                   m = MATCH_ERROR;
2850                   goto cleanup;
2851                 }
2852             }
2853           else
2854             {
2855               gfc_error ("%s attribute at %L is not allowed outside of the "
2856                          "specification part of a module", attr, &seen_at[d]);
2857               m = MATCH_ERROR;
2858               goto cleanup;
2859             }
2860         }
2861
2862       switch (d)
2863         {
2864         case DECL_ALLOCATABLE:
2865           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2866           break;
2867
2868         case DECL_DIMENSION:
2869           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
2870           break;
2871
2872         case DECL_EXTERNAL:
2873           t = gfc_add_external (&current_attr, &seen_at[d]);
2874           break;
2875
2876         case DECL_IN:
2877           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2878           break;
2879
2880         case DECL_OUT:
2881           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2882           break;
2883
2884         case DECL_INOUT:
2885           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2886           break;
2887
2888         case DECL_INTRINSIC:
2889           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2890           break;
2891
2892         case DECL_OPTIONAL:
2893           t = gfc_add_optional (&current_attr, &seen_at[d]);
2894           break;
2895
2896         case DECL_PARAMETER:
2897           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
2898           break;
2899
2900         case DECL_POINTER:
2901           t = gfc_add_pointer (&current_attr, &seen_at[d]);
2902           break;
2903
2904         case DECL_PROTECTED:
2905           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2906             {
2907                gfc_error ("PROTECTED at %C only allowed in specification "
2908                           "part of a module");
2909                t = FAILURE;
2910                break;
2911             }
2912
2913           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2914                               "attribute at %C")
2915               == FAILURE)
2916             t = FAILURE;
2917           else
2918             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
2919           break;
2920
2921         case DECL_PRIVATE:
2922           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2923                               &seen_at[d]);
2924           break;
2925
2926         case DECL_PUBLIC:
2927           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2928                               &seen_at[d]);
2929           break;
2930
2931         case DECL_SAVE:
2932           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
2933           break;
2934
2935         case DECL_TARGET:
2936           t = gfc_add_target (&current_attr, &seen_at[d]);
2937           break;
2938
2939         case DECL_IS_BIND_C:
2940            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
2941            break;
2942
2943         case DECL_VALUE:
2944           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2945                               "at %C")
2946               == FAILURE)
2947             t = FAILURE;
2948           else
2949             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
2950           break;
2951
2952         case DECL_VOLATILE:
2953           if (gfc_notify_std (GFC_STD_F2003,
2954                               "Fortran 2003: VOLATILE attribute at %C")
2955               == FAILURE)
2956             t = FAILURE;
2957           else
2958             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2959           break;
2960
2961         default:
2962           gfc_internal_error ("match_attr_spec(): Bad attribute");
2963         }
2964
2965       if (t == FAILURE)
2966         {
2967           m = MATCH_ERROR;
2968           goto cleanup;
2969         }
2970     }
2971
2972   colon_seen = 1;
2973   return MATCH_YES;
2974
2975 cleanup:
2976   gfc_current_locus = start;
2977   gfc_free_array_spec (current_as);
2978   current_as = NULL;
2979   return m;
2980 }
2981
2982
2983 /* Set the binding label, dest_label, either with the binding label
2984    stored in the given gfc_typespec, ts, or if none was provided, it
2985    will be the symbol name in all lower case, as required by the draft
2986    (J3/04-007, section 15.4.1).  If a binding label was given and
2987    there is more than one argument (num_idents), it is an error.  */
2988
2989 try
2990 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
2991 {
2992   if (num_idents > 1 && has_name_equals)
2993     {
2994       gfc_error ("Multiple identifiers provided with "
2995                  "single NAME= specifier at %C");
2996       return FAILURE;
2997     }
2998
2999   if (curr_binding_label[0] != '\0')
3000     {
3001       /* Binding label given; store in temp holder til have sym.  */
3002       strncpy (dest_label, curr_binding_label,
3003                strlen (curr_binding_label) + 1);
3004     }
3005   else
3006     {
3007       /* No binding label given, and the NAME= specifier did not exist,
3008          which means there was no NAME="".  */
3009       if (sym_name != NULL && has_name_equals == 0)
3010         strncpy (dest_label, sym_name, strlen (sym_name) + 1);
3011     }
3012
3013   return SUCCESS;
3014 }
3015
3016
3017 /* Set the status of the given common block as being BIND(C) or not,
3018    depending on the given parameter, is_bind_c.  */
3019
3020 void
3021 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3022 {
3023   com_block->is_bind_c = is_bind_c;
3024   return;
3025 }
3026
3027
3028 /* Verify that the given gfc_typespec is for a C interoperable type.  */
3029
3030 try
3031 verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
3032 {
3033   try t;
3034
3035   /* Make sure the kind used is appropriate for the type.
3036      The f90_type is unknown if an integer constant was
3037      used (e.g., real(4), bind(c) :: myFloat).  */
3038   if (ts->f90_type != BT_UNKNOWN)
3039     {
3040       t = gfc_validate_c_kind (ts);
3041       if (t != SUCCESS)
3042         {
3043           /* Print an error, but continue parsing line.  */
3044           gfc_error_now ("C kind parameter is for type %s but "
3045                          "symbol '%s' at %L is of type %s",
3046                          gfc_basic_typename (ts->f90_type),
3047                          name, where,
3048                          gfc_basic_typename (ts->type));
3049         }
3050     }
3051
3052   /* Make sure the kind is C interoperable.  This does not care about the
3053      possible error above.  */
3054   if (ts->type == BT_DERIVED && ts->derived != NULL)
3055     return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
3056   else if (ts->is_c_interop != 1)
3057     return FAILURE;
3058
3059   return SUCCESS;
3060 }
3061
3062
3063 /* Verify that the variables of a given common block, which has been
3064    defined with the attribute specifier bind(c), to be of a C
3065    interoperable type.  Errors will be reported here, if
3066    encountered.  */
3067
3068 try
3069 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3070 {
3071   gfc_symbol *curr_sym = NULL;
3072   try retval = SUCCESS;
3073
3074   curr_sym = com_block->head;
3075
3076   /* Make sure we have at least one symbol.  */
3077   if (curr_sym == NULL)
3078     return retval;
3079
3080   /* Here we know we have a symbol, so we'll execute this loop
3081      at least once.  */
3082   do
3083     {
3084       /* The second to last param, 1, says this is in a common block.  */
3085       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3086       curr_sym = curr_sym->common_next;
3087     } while (curr_sym != NULL);
3088
3089   return retval;
3090 }
3091
3092
3093 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
3094    an appropriate error message is reported.  */
3095
3096 try
3097 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3098                    int is_in_common, gfc_common_head *com_block)
3099 {
3100   try retval = SUCCESS;
3101
3102   if (tmp_sym->attr.function && tmp_sym->result != NULL)
3103     {
3104       tmp_sym = tmp_sym->result;
3105       /* Make sure it wasn't an implicitly typed result.  */
3106       if (tmp_sym->attr.implicit_type)
3107         {
3108           gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3109                        "%L may not be C interoperable", tmp_sym->name,
3110                        &tmp_sym->declared_at);
3111           tmp_sym->ts.f90_type = tmp_sym->ts.type;
3112           /* Mark it as C interoperable to prevent duplicate warnings.  */
3113           tmp_sym->ts.is_c_interop = 1;
3114           tmp_sym->attr.is_c_interop = 1;
3115         }
3116     }
3117
3118   /* Here, we know we have the bind(c) attribute, so if we have
3119      enough type info, then verify that it's a C interop kind.
3120      The info could be in the symbol already, or possibly still in
3121      the given ts (current_ts), so look in both.  */
3122   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
3123     {
3124       if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
3125                             &(tmp_sym->declared_at)) != SUCCESS)
3126         {
3127           /* See if we're dealing with a sym in a common block or not.  */
3128           if (is_in_common == 1)
3129             {
3130               gfc_warning ("Variable '%s' in common block '%s' at %L "
3131                            "may not be a C interoperable "
3132                            "kind though common block '%s' is BIND(C)",
3133                            tmp_sym->name, com_block->name,
3134                            &(tmp_sym->declared_at), com_block->name);
3135             }
3136           else
3137             {
3138               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3139                 gfc_error ("Type declaration '%s' at %L is not C "
3140                            "interoperable but it is BIND(C)",
3141                            tmp_sym->name, &(tmp_sym->declared_at));
3142               else
3143                 gfc_warning ("Variable '%s' at %L "
3144                              "may not be a C interoperable "
3145                              "kind but it is bind(c)",
3146                              tmp_sym->name, &(tmp_sym->declared_at));
3147             }
3148         }
3149
3150       /* Variables declared w/in a common block can't be bind(c)
3151          since there's no way for C to see these variables, so there's
3152          semantically no reason for the attribute.  */
3153       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3154         {
3155           gfc_error ("Variable '%s' in common block '%s' at "
3156                      "%L cannot be declared with BIND(C) "
3157                      "since it is not a global",
3158                      tmp_sym->name, com_block->name,
3159                      &(tmp_sym->declared_at));
3160           retval = FAILURE;
3161         }
3162
3163       /* Scalar variables that are bind(c) can not have the pointer
3164          or allocatable attributes.  */
3165       if (tmp_sym->attr.is_bind_c == 1)
3166         {
3167           if (tmp_sym->attr.pointer == 1)
3168             {
3169               gfc_error ("Variable '%s' at %L cannot have both the "
3170                          "POINTER and BIND(C) attributes",
3171                          tmp_sym->name, &(tmp_sym->declared_at));
3172               retval = FAILURE;
3173             }
3174
3175           if (tmp_sym->attr.allocatable == 1)
3176             {
3177               gfc_error ("Variable '%s' at %L cannot have both the "
3178                          "ALLOCATABLE and BIND(C) attributes",
3179                          tmp_sym->name, &(tmp_sym->declared_at));
3180               retval = FAILURE;
3181             }
3182
3183           /* If it is a BIND(C) function, make sure the return value is a
3184              scalar value.  The previous tests in this function made sure
3185              the type is interoperable.  */
3186           if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3187             gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3188                        "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3189
3190           /* BIND(C) functions can not return a character string.  */
3191           if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3192             if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3193                 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3194                 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3195               gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3196                          "be a character string", tmp_sym->name,
3197                          &(tmp_sym->declared_at));
3198         }
3199     }
3200
3201   /* See if the symbol has been marked as private.  If it has, make sure
3202      there is no binding label and warn the user if there is one.  */
3203   if (tmp_sym->attr.access == ACCESS_PRIVATE
3204       && tmp_sym->binding_label[0] != '\0')
3205       /* Use gfc_warning_now because we won't say that the symbol fails
3206          just because of this.  */
3207       gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3208                        "given the binding label '%s'", tmp_sym->name,
3209                        &(tmp_sym->declared_at), tmp_sym->binding_label);
3210
3211   return retval;
3212 }
3213
3214
3215 /* Set the appropriate fields for a symbol that's been declared as
3216    BIND(C) (the is_bind_c flag and the binding label), and verify that
3217    the type is C interoperable.  Errors are reported by the functions
3218    used to set/test these fields.  */
3219
3220 try
3221 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3222 {
3223   try retval = SUCCESS;
3224
3225   /* TODO: Do we need to make sure the vars aren't marked private?  */
3226
3227   /* Set the is_bind_c bit in symbol_attribute.  */
3228   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3229
3230   if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3231                          num_idents) != SUCCESS)
3232     return FAILURE;
3233
3234   return retval;
3235 }
3236
3237
3238 /* Set the fields marking the given common block as BIND(C), including
3239    a binding label, and report any errors encountered.  */
3240
3241 try
3242 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3243 {
3244   try retval = SUCCESS;
3245
3246   /* destLabel, common name, typespec (which may have binding label).  */
3247   if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3248       != SUCCESS)
3249     return FAILURE;
3250
3251   /* Set the given common block (com_block) to being bind(c) (1).  */
3252   set_com_block_bind_c (com_block, 1);
3253
3254   return retval;
3255 }
3256
3257
3258 /* Retrieve the list of one or more identifiers that the given bind(c)
3259    attribute applies to.  */
3260
3261 try
3262 get_bind_c_idents (void)
3263 {
3264   char name[GFC_MAX_SYMBOL_LEN + 1];
3265   int num_idents = 0;
3266   gfc_symbol *tmp_sym = NULL;
3267   match found_id;
3268   gfc_common_head *com_block = NULL;
3269
3270   if (gfc_match_name (name) == MATCH_YES)
3271     {
3272       found_id = MATCH_YES;
3273       gfc_get_ha_symbol (name, &tmp_sym);
3274     }
3275   else if (match_common_name (name) == MATCH_YES)
3276     {
3277       found_id = MATCH_YES;
3278       com_block = gfc_get_common (name, 0);
3279     }
3280   else
3281     {
3282       gfc_error ("Need either entity or common block name for "
3283                  "attribute specification statement at %C");
3284       return FAILURE;
3285     }
3286
3287   /* Save the current identifier and look for more.  */
3288   do
3289     {
3290       /* Increment the number of identifiers found for this spec stmt.  */
3291       num_idents++;
3292
3293       /* Make sure we have a sym or com block, and verify that it can
3294          be bind(c).  Set the appropriate field(s) and look for more
3295          identifiers.  */
3296       if (tmp_sym != NULL || com_block != NULL)
3297         {
3298           if (tmp_sym != NULL)
3299             {
3300               if (set_verify_bind_c_sym (tmp_sym, num_idents)
3301                   != SUCCESS)
3302                 return FAILURE;
3303             }
3304           else
3305             {
3306               if (set_verify_bind_c_com_block(com_block, num_idents)
3307                   != SUCCESS)
3308                 return FAILURE;
3309             }
3310
3311           /* Look to see if we have another identifier.  */
3312           tmp_sym = NULL;
3313           if (gfc_match_eos () == MATCH_YES)
3314             found_id = MATCH_NO;
3315           else if (gfc_match_char (',') != MATCH_YES)
3316             found_id = MATCH_NO;
3317           else if (gfc_match_name (name) == MATCH_YES)
3318             {
3319               found_id = MATCH_YES;
3320               gfc_get_ha_symbol (name, &tmp_sym);
3321             }
3322           else if (match_common_name (name) == MATCH_YES)
3323             {
3324               found_id = MATCH_YES;
3325               com_block = gfc_get_common (name, 0);
3326             }
3327           else
3328             {
3329               gfc_error ("Missing entity or common block name for "
3330                          "attribute specification statement at %C");
3331               return FAILURE;
3332             }
3333         }
3334       else
3335         {
3336           gfc_internal_error ("Missing symbol");
3337         }
3338     } while (found_id == MATCH_YES);
3339
3340   /* if we get here we were successful */
3341   return SUCCESS;
3342 }
3343
3344
3345 /* Try and match a BIND(C) attribute specification statement.  */
3346
3347 match
3348 gfc_match_bind_c_stmt (void)
3349 {
3350   match found_match = MATCH_NO;
3351   gfc_typespec *ts;
3352
3353   ts = &current_ts;
3354
3355   /* This may not be necessary.  */
3356   gfc_clear_ts (ts);
3357   /* Clear the temporary binding label holder.  */
3358   curr_binding_label[0] = '\0';
3359
3360   /* Look for the bind(c).  */
3361   found_match = gfc_match_bind_c (NULL);
3362
3363   if (found_match == MATCH_YES)
3364     {
3365       /* Look for the :: now, but it is not required.  */
3366       gfc_match (" :: ");
3367
3368       /* Get the identifier(s) that needs to be updated.  This may need to
3369          change to hand the flag(s) for the attr specified so all identifiers
3370          found can have all appropriate parts updated (assuming that the same
3371          spec stmt can have multiple attrs, such as both bind(c) and
3372          allocatable...).  */
3373       if (get_bind_c_idents () != SUCCESS)
3374         /* Error message should have printed already.  */
3375         return MATCH_ERROR;
3376     }
3377
3378   return found_match;
3379 }
3380
3381
3382 /* Match a data declaration statement.  */
3383
3384 match
3385 gfc_match_data_decl (void)
3386 {
3387   gfc_symbol *sym;
3388   match m;
3389   int elem;
3390
3391   num_idents_on_line = 0;
3392
3393   m = match_type_spec (&current_ts, 0);
3394   if (m != MATCH_YES)
3395     return m;
3396
3397   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3398     {
3399       sym = gfc_use_derived (current_ts.derived);
3400
3401       if (sym == NULL)
3402         {
3403           m = MATCH_ERROR;
3404           goto cleanup;
3405         }
3406
3407       current_ts.derived = sym;
3408     }
3409
3410   m = match_attr_spec ();
3411   if (m == MATCH_ERROR)
3412     {
3413       m = MATCH_NO;
3414       goto cleanup;
3415     }
3416
3417   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
3418     {
3419
3420       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3421         goto ok;
3422
3423       gfc_find_symbol (current_ts.derived->name,
3424                        current_ts.derived->ns->parent, 1, &sym);
3425
3426       /* Any symbol that we find had better be a type definition
3427          which has its components defined.  */
3428       if (sym != NULL && sym->attr.flavor == FL_DERIVED
3429           && current_ts.derived->components != NULL)
3430         goto ok;
3431
3432       /* Now we have an error, which we signal, and then fix up
3433          because the knock-on is plain and simple confusing.  */
3434       gfc_error_now ("Derived type at %C has not been previously defined "
3435                      "and so cannot appear in a derived type definition");
3436       current_attr.pointer = 1;
3437       goto ok;
3438     }
3439
3440 ok:
3441   /* If we have an old-style character declaration, and no new-style
3442      attribute specifications, then there a comma is optional between
3443      the type specification and the variable list.  */
3444   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3445     gfc_match_char (',');
3446
3447   /* Give the types/attributes to symbols that follow. Give the element
3448      a number so that repeat character length expressions can be copied.  */
3449   elem = 1;
3450   for (;;)
3451     {
3452       num_idents_on_line++;
3453       m = variable_decl (elem++);
3454       if (m == MATCH_ERROR)
3455         goto cleanup;
3456       if (m == MATCH_NO)
3457         break;
3458
3459       if (gfc_match_eos () == MATCH_YES)
3460         goto cleanup;
3461       if (gfc_match_char (',') != MATCH_YES)
3462         break;
3463     }
3464
3465   if (gfc_error_flag_test () == 0)
3466     gfc_error ("Syntax error in data declaration at %C");
3467   m = MATCH_ERROR;
3468
3469   gfc_free_data_all (gfc_current_ns);
3470
3471 cleanup:
3472   gfc_free_array_spec (current_as);
3473   current_as = NULL;
3474   return m;
3475 }
3476
3477
3478 /* Match a prefix associated with a function or subroutine
3479    declaration.  If the typespec pointer is nonnull, then a typespec
3480    can be matched.  Note that if nothing matches, MATCH_YES is
3481    returned (the null string was matched).  */
3482
3483 static match
3484 match_prefix (gfc_typespec *ts)
3485 {
3486   int seen_type;
3487
3488   gfc_clear_attr (&current_attr);
3489   seen_type = 0;
3490
3491 loop:
3492   if (!seen_type && ts != NULL
3493       && match_type_spec (ts, 0) == MATCH_YES
3494       && gfc_match_space () == MATCH_YES)
3495     {
3496
3497       seen_type = 1;
3498       goto loop;
3499     }
3500
3501   if (gfc_match ("elemental% ") == MATCH_YES)
3502     {
3503       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3504         return MATCH_ERROR;
3505
3506       goto loop;
3507     }
3508
3509   if (gfc_match ("pure% ") == MATCH_YES)
3510     {
3511       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3512         return MATCH_ERROR;
3513
3514       goto loop;
3515     }
3516
3517   if (gfc_match ("recursive% ") == MATCH_YES)
3518     {
3519       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3520         return MATCH_ERROR;
3521
3522       goto loop;
3523     }
3524
3525   /* At this point, the next item is not a prefix.  */
3526   return MATCH_YES;
3527 }
3528
3529
3530 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
3531
3532 static try
3533 copy_prefix (symbol_attribute *dest, locus *where)
3534 {
3535   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3536     return FAILURE;
3537
3538   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3539     return FAILURE;
3540
3541   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3542     return FAILURE;
3543
3544   return SUCCESS;
3545 }
3546
3547
3548 /* Match a formal argument list.  */
3549
3550 match
3551 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3552 {
3553   gfc_formal_arglist *head, *tail, *p, *q;
3554   char name[GFC_MAX_SYMBOL_LEN + 1];
3555   gfc_symbol *sym;
3556   match m;
3557
3558   head = tail = NULL;
3559
3560   if (gfc_match_char ('(') != MATCH_YES)
3561     {
3562       if (null_flag)
3563         goto ok;
3564       return MATCH_NO;
3565     }
3566
3567   if (gfc_match_char (')') == MATCH_YES)
3568     goto ok;
3569
3570   for (;;)
3571     {
3572       if (gfc_match_char ('*') == MATCH_YES)
3573         sym = NULL;
3574       else
3575         {
3576           m = gfc_match_name (name);
3577           if (m != MATCH_YES)
3578             goto cleanup;
3579
3580           if (gfc_get_symbol (name, NULL, &sym))
3581             goto cleanup;
3582         }
3583
3584       p = gfc_get_formal_arglist ();
3585
3586       if (head == NULL)
3587         head = tail = p;
3588       else
3589         {
3590           tail->next = p;
3591           tail = p;
3592         }
3593
3594       tail->sym = sym;
3595
3596       /* We don't add the VARIABLE flavor because the name could be a
3597          dummy procedure.  We don't apply these attributes to formal
3598          arguments of statement functions.  */
3599       if (sym != NULL && !st_flag
3600           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3601               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3602         {
3603           m = MATCH_ERROR;
3604           goto cleanup;
3605         }
3606
3607       /* The name of a program unit can be in a different namespace,
3608          so check for it explicitly.  After the statement is accepted,
3609          the name is checked for especially in gfc_get_symbol().  */
3610       if (gfc_new_block != NULL && sym != NULL
3611           && strcmp (sym->name, gfc_new_block->name) == 0)
3612         {
3613           gfc_error ("Name '%s' at %C is the name of the procedure",
3614                      sym->name);
3615           m = MATCH_ERROR;
3616           goto cleanup;
3617         }
3618
3619       if (gfc_match_char (')') == MATCH_YES)
3620         goto ok;
3621
3622       m = gfc_match_char (',');
3623       if (m != MATCH_YES)
3624         {
3625           gfc_error ("Unexpected junk in formal argument list at %C");
3626           goto cleanup;
3627         }
3628     }
3629
3630 ok:
3631   /* Check for duplicate symbols in the formal argument list.  */
3632   if (head != NULL)
3633     {
3634       for (p = head; p->next; p = p->next)
3635         {
3636           if (p->sym == NULL)
3637             continue;
3638
3639           for (q = p->next; q; q = q->next)
3640             if (p->sym == q->sym)
3641               {
3642                 gfc_error ("Duplicate symbol '%s' in formal argument list "
3643                            "at %C", p->sym->name);
3644
3645                 m = MATCH_ERROR;
3646                 goto cleanup;
3647               }
3648         }
3649     }
3650
3651   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3652       == FAILURE)
3653     {
3654       m = MATCH_ERROR;
3655       goto cleanup;
3656     }
3657
3658   return MATCH_YES;
3659
3660 cleanup:
3661   gfc_free_formal_arglist (head);
3662   return m;
3663 }
3664
3665
3666 /* Match a RESULT specification following a function declaration or
3667    ENTRY statement.  Also matches the end-of-statement.  */
3668
3669 static match
3670 match_result (gfc_symbol *function, gfc_symbol **result)
3671 {
3672   char name[GFC_MAX_SYMBOL_LEN + 1];
3673   gfc_symbol *r;
3674   match m;
3675
3676   if (gfc_match (" result (") != MATCH_YES)
3677     return MATCH_NO;
3678
3679   m = gfc_match_name (name);
3680   if (m != MATCH_YES)
3681     return m;
3682
3683   /* Get the right paren, and that's it because there could be the
3684      bind(c) attribute after the result clause.  */
3685   if (gfc_match_char(')') != MATCH_YES)
3686     {
3687      /* TODO: should report the missing right paren here.  */
3688       return MATCH_ERROR;
3689     }
3690
3691   if (strcmp (function->name, name) == 0)
3692     {
3693       gfc_error ("RESULT variable at %C must be different than function name");
3694       return MATCH_ERROR;
3695     }
3696
3697   if (gfc_get_symbol (name, NULL, &r))
3698     return MATCH_ERROR;
3699
3700   if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3701       || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3702     return MATCH_ERROR;
3703
3704   *result = r;
3705
3706   return MATCH_YES;
3707 }
3708
3709
3710 /* Match a function suffix, which could be a combination of a result
3711    clause and BIND(C), either one, or neither.  The draft does not
3712    require them to come in a specific order.  */
3713
3714 match
3715 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3716 {
3717   match is_bind_c;   /* Found bind(c).  */
3718   match is_result;   /* Found result clause.  */
3719   match found_match; /* Status of whether we've found a good match.  */
3720   int peek_char;     /* Character we're going to peek at.  */
3721
3722   /* Initialize to having found nothing.  */
3723   found_match = MATCH_NO;
3724   is_bind_c = MATCH_NO;
3725   is_result = MATCH_NO;
3726
3727   /* Get the next char to narrow between result and bind(c).  */
3728   gfc_gobble_whitespace ();
3729   peek_char = gfc_peek_char ();
3730
3731   switch (peek_char)
3732     {
3733     case 'r':
3734       /* Look for result clause.  */
3735       is_result = match_result (sym, result);
3736       if (is_result == MATCH_YES)
3737         {
3738           /* Now see if there is a bind(c) after it.  */
3739           is_bind_c = gfc_match_bind_c (sym);
3740           /* We've found the result clause and possibly bind(c).  */
3741           found_match = MATCH_YES;
3742         }
3743       else
3744         /* This should only be MATCH_ERROR.  */
3745         found_match = is_result;
3746       break;
3747     case 'b':
3748       /* Look for bind(c) first.  */
3749       is_bind_c = gfc_match_bind_c (sym);
3750       if (is_bind_c == MATCH_YES)
3751         {
3752           /* Now see if a result clause followed it.  */
3753           is_result = match_result (sym, result);
3754           found_match = MATCH_YES;
3755         }
3756       else
3757         {
3758           /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
3759           found_match = MATCH_ERROR;
3760         }
3761       break;
3762     default:
3763       gfc_error ("Unexpected junk after function declaration at %C");
3764       found_match = MATCH_ERROR;
3765       break;
3766     }
3767
3768   if (is_bind_c == MATCH_YES)
3769     if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3770         == FAILURE)
3771       return MATCH_ERROR;
3772
3773   return found_match;
3774 }
3775
3776
3777 /* Match a PROCEDURE declaration (R1211).  */
3778
3779 static match
3780 match_procedure_decl (void)
3781 {
3782   match m;
3783   locus old_loc, entry_loc;
3784   gfc_symbol *sym, *proc_if = NULL;
3785   int num;
3786
3787   old_loc = entry_loc = gfc_current_locus;
3788
3789   gfc_clear_ts (&current_ts);
3790
3791   if (gfc_match (" (") != MATCH_YES)
3792     {
3793       gfc_current_locus = entry_loc;
3794       return MATCH_NO;
3795     }
3796
3797   /* Get the type spec. for the procedure interface.  */
3798   old_loc = gfc_current_locus;
3799   m = match_type_spec (&current_ts, 0);
3800   if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
3801     goto got_ts;
3802
3803   if (m == MATCH_ERROR)
3804     return m;
3805
3806   gfc_current_locus = old_loc;
3807
3808   /* Get the name of the procedure or abstract interface
3809   to inherit the interface from.  */
3810   m = gfc_match_symbol (&proc_if, 1);
3811
3812   if (m == MATCH_NO)
3813     goto syntax;
3814   else if (m == MATCH_ERROR)
3815     return m;
3816
3817   /* Various interface checks.  */
3818   if (proc_if)
3819     {
3820       if (proc_if->generic)
3821         {
3822           gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
3823           return MATCH_ERROR;
3824         }
3825       if (proc_if->attr.proc == PROC_ST_FUNCTION)
3826         {
3827           gfc_error ("Interface '%s' at %C may not be a statement function",
3828                     proc_if->name);
3829           return MATCH_ERROR;
3830         }
3831       /* Handle intrinsic procedures.  */
3832       if (gfc_intrinsic_name (proc_if->name, 0)
3833           || gfc_intrinsic_name (proc_if->name, 1))
3834         proc_if->attr.intrinsic = 1;
3835       if (proc_if->attr.intrinsic
3836           && !gfc_intrinsic_actual_ok (proc_if->name, 0))
3837         {
3838           gfc_error ("Intrinsic procedure '%s' not allowed "
3839                     "in PROCEDURE statement at %C", proc_if->name);
3840           return MATCH_ERROR;
3841         }
3842       /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
3843          (proc_if->name, 0) after PR33162 is fixed.  */
3844       if (proc_if->attr.intrinsic)
3845         {
3846           gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
3847                      "in PROCEDURE statement at %C not yet implemented "
3848                      "in gfortran", proc_if->name);
3849           return MATCH_ERROR;
3850         }
3851     }
3852
3853 got_ts:
3854
3855   if (gfc_match (" )") != MATCH_YES)
3856     {
3857       gfc_current_locus = entry_loc;
3858       return MATCH_NO;
3859     }
3860
3861   /* Parse attributes.  */
3862   m = match_attr_spec();
3863   if (m == MATCH_ERROR)
3864     return MATCH_ERROR;
3865
3866   /* Get procedure symbols.  */
3867   for(num=1;;num++)
3868     {
3869
3870       m = gfc_match_symbol (&sym, 0);
3871       if (m == MATCH_NO)
3872         goto syntax;
3873       else if (m == MATCH_ERROR)
3874         return m;
3875
3876       /* Add current_attr to the symbol attributes.  */
3877       if (gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3878         return MATCH_ERROR;
3879
3880       if (sym->attr.is_bind_c)
3881         {
3882           /* Check for C1218.  */
3883           if (!proc_if || !proc_if->attr.is_bind_c)
3884             {
3885               gfc_error ("BIND(C) attribute at %C requires "
3886                         "an interface with BIND(C)");
3887               return MATCH_ERROR;
3888             }
3889           /* Check for C1217.  */
3890           if (has_name_equals && sym->attr.pointer)
3891             {
3892               gfc_error ("BIND(C) procedure with NAME may not have "
3893                         "POINTER attribute at %C");
3894               return MATCH_ERROR;
3895             }
3896           if (has_name_equals && sym->attr.dummy)
3897             {
3898               gfc_error ("Dummy procedure at %C may not have "
3899                         "BIND(C) attribute with NAME");
3900               return MATCH_ERROR;
3901             }
3902           /* Set binding label for BIND(C).  */
3903           if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
3904             return MATCH_ERROR;
3905         }
3906
3907       if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
3908         return MATCH_ERROR;
3909       if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
3910         return MATCH_ERROR;
3911
3912       /* Set interface.  */
3913       if (proc_if != NULL)
3914         sym->interface = proc_if;
3915       else if (current_ts.type != BT_UNKNOWN)
3916         {
3917           sym->interface = gfc_new_symbol ("", gfc_current_ns);
3918           sym->interface->ts = current_ts;
3919           sym->interface->attr.function = 1;
3920           sym->ts = sym->interface->ts;
3921           sym->attr.function = sym->interface->attr.function;
3922         }
3923
3924       if (gfc_match_eos () == MATCH_YES)
3925         return MATCH_YES;
3926       if (gfc_match_char (',') != MATCH_YES)
3927         goto syntax;
3928     }
3929
3930 syntax:
3931   gfc_error ("Syntax error in PROCEDURE statement at %C");
3932   return MATCH_ERROR;
3933 }
3934
3935
3936 /* Match a PROCEDURE declaration inside an interface (R1206).  */
3937
3938 static match
3939 match_procedure_in_interface (void)
3940 {
3941   match m;
3942   gfc_symbol *sym;
3943   char name[GFC_MAX_SYMBOL_LEN + 1];
3944
3945   if (current_interface.type == INTERFACE_NAMELESS
3946       || current_interface.type == INTERFACE_ABSTRACT)
3947     {
3948       gfc_error ("PROCEDURE at %C must be in a generic interface");
3949       return MATCH_ERROR;
3950     }
3951
3952   for(;;)
3953     {
3954       m = gfc_match_name (name);
3955       if (m == MATCH_NO)
3956         goto syntax;
3957       else if (m == MATCH_ERROR)
3958         return m;
3959       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3960         return MATCH_ERROR;
3961
3962       if (gfc_add_interface (sym) == FAILURE)
3963         return MATCH_ERROR;
3964
3965       sym->attr.procedure = 1;
3966
3967       if (gfc_match_eos () == MATCH_YES)
3968         break;
3969       if (gfc_match_char (',') != MATCH_YES)
3970         goto syntax;
3971     }
3972
3973   return MATCH_YES;
3974
3975 syntax:
3976   gfc_error ("Syntax error in PROCEDURE statement at %C");
3977   return MATCH_ERROR;
3978 }
3979
3980
3981 /* General matcher for PROCEDURE declarations.  */
3982
3983 match
3984 gfc_match_procedure (void)
3985 {
3986   match m;
3987
3988   switch (gfc_current_state ())
3989     {
3990     case COMP_NONE:
3991     case COMP_PROGRAM:
3992     case COMP_MODULE:
3993     case COMP_SUBROUTINE:
3994     case COMP_FUNCTION:
3995       m = match_procedure_decl ();
3996       break;
3997     case COMP_INTERFACE:
3998       m = match_procedure_in_interface ();
3999       break;
4000     case COMP_DERIVED:
4001       gfc_error ("Fortran 2003: Procedure components at %C are "
4002                 "not yet implemented in gfortran");
4003       return MATCH_ERROR;
4004     default:
4005       return MATCH_NO;
4006     }
4007
4008   if (m != MATCH_YES)
4009     return m;
4010
4011   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
4012       == FAILURE)
4013     return MATCH_ERROR;
4014
4015   return m;
4016 }
4017
4018
4019 /* Match a function declaration.  */
4020
4021 match
4022 gfc_match_function_decl (void)
4023 {
4024   char name[GFC_MAX_SYMBOL_LEN + 1];
4025   gfc_symbol *sym, *result;
4026   locus old_loc;
4027   match m;
4028   match suffix_match;
4029   match found_match; /* Status returned by match func.  */
4030
4031   if (gfc_current_state () != COMP_NONE
4032       && gfc_current_state () != COMP_INTERFACE
4033       && gfc_current_state () != COMP_CONTAINS)
4034     return MATCH_NO;
4035
4036   gfc_clear_ts (&current_ts);
4037
4038   old_loc = gfc_current_locus;
4039
4040   m = match_prefix (&current_ts);
4041   if (m != MATCH_YES)
4042     {
4043       gfc_current_locus = old_loc;
4044       return m;
4045     }
4046
4047   if (gfc_match ("function% %n", name) != MATCH_YES)
4048     {
4049       gfc_current_locus = old_loc;
4050       return MATCH_NO;
4051     }
4052   if (get_proc_name (name, &sym, false))
4053     return MATCH_ERROR;
4054   gfc_new_block = sym;
4055
4056   m = gfc_match_formal_arglist (sym, 0, 0);
4057   if (m == MATCH_NO)
4058     {
4059       gfc_error ("Expected formal argument list in function "
4060                  "definition at %C");
4061       m = MATCH_ERROR;
4062       goto cleanup;
4063     }
4064   else if (m == MATCH_ERROR)
4065     goto cleanup;
4066
4067   result = NULL;
4068
4069   /* According to the draft, the bind(c) and result clause can
4070      come in either order after the formal_arg_list (i.e., either
4071      can be first, both can exist together or by themselves or neither
4072      one).  Therefore, the match_result can't match the end of the
4073      string, and check for the bind(c) or result clause in either order.  */
4074   found_match = gfc_match_eos ();
4075
4076   /* Make sure that it isn't already declared as BIND(C).  If it is, it
4077      must have been marked BIND(C) with a BIND(C) attribute and that is
4078      not allowed for procedures.  */
4079   if (sym->attr.is_bind_c == 1)
4080     {
4081       sym->attr.is_bind_c = 0;
4082       if (sym->old_symbol != NULL)
4083         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4084                        "variables or common blocks",
4085                        &(sym->old_symbol->declared_at));
4086       else
4087         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4088                        "variables or common blocks", &gfc_current_locus);
4089     }
4090
4091   if (found_match != MATCH_YES)
4092     {
4093       /* If we haven't found the end-of-statement, look for a suffix.  */
4094       suffix_match = gfc_match_suffix (sym, &result);
4095       if (suffix_match == MATCH_YES)
4096         /* Need to get the eos now.  */
4097         found_match = gfc_match_eos ();
4098       else
4099         found_match = suffix_match;
4100     }
4101
4102   if(found_match != MATCH_YES)
4103     m = MATCH_ERROR;
4104   else
4105     {
4106       /* Make changes to the symbol.  */
4107       m = MATCH_ERROR;
4108
4109       if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
4110         goto cleanup;
4111
4112       if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
4113           || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4114         goto cleanup;
4115
4116       if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
4117           && !sym->attr.implicit_type)
4118         {
4119           gfc_error ("Function '%s' at %C already has a type of %s", name,
4120                      gfc_basic_typename (sym->ts.type));
4121           goto cleanup;
4122         }
4123
4124       if (result == NULL)
4125         {
4126           sym->ts = current_ts;
4127           sym->result = sym;
4128         }
4129       else
4130         {
4131           result->ts = current_ts;
4132           sym->result = result;
4133         }
4134
4135       return MATCH_YES;
4136     }
4137
4138 cleanup:
4139   gfc_current_locus = old_loc;
4140   return m;
4141 }
4142
4143
4144 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
4145    pass the name of the entry, rather than the gfc_current_block name, and
4146    to return false upon finding an existing global entry.  */
4147
4148 static bool
4149 add_global_entry (const char *name, int sub)
4150 {
4151   gfc_gsymbol *s;
4152
4153   s = gfc_get_gsymbol(name);
4154
4155   if (s->defined
4156       || (s->type != GSYM_UNKNOWN
4157           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4158     global_used(s, NULL);
4159   else
4160     {
4161       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4162       s->where = gfc_current_locus;
4163       s->defined = 1;
4164       return true;
4165     }
4166   return false;
4167 }
4168
4169
4170 /* Match an ENTRY statement.  */
4171
4172 match
4173 gfc_match_entry (void)
4174 {
4175   gfc_symbol *proc;
4176   gfc_symbol *result;
4177   gfc_symbol *entry;
4178   char name[GFC_MAX_SYMBOL_LEN + 1];
4179   gfc_compile_state state;
4180   match m;
4181   gfc_entry_list *el;
4182   locus old_loc;
4183   bool module_procedure;
4184
4185   m = gfc_match_name (name);
4186   if (m != MATCH_YES)
4187     return m;
4188
4189   state = gfc_current_state ();
4190   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
4191     {
4192       switch (state)
4193         {
4194           case COMP_PROGRAM:
4195             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
4196             break;
4197           case COMP_MODULE:
4198             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
4199             break;
4200           case COMP_BLOCK_DATA:
4201             gfc_error ("ENTRY statement at %C cannot appear within "
4202                        "a BLOCK DATA");
4203             break;
4204           case COMP_INTERFACE:
4205             gfc_error ("ENTRY statement at %C cannot appear within "
4206                        "an INTERFACE");
4207             break;
4208           case COMP_DERIVED:
4209             gfc_error ("ENTRY statement at %C cannot appear within "
4210                        "a DERIVED TYPE block");
4211             break;
4212           case COMP_IF:
4213             gfc_error ("ENTRY statement at %C cannot appear within "
4214                        "an IF-THEN block");
4215             break;
4216           case COMP_DO:
4217             gfc_error ("ENTRY statement at %C cannot appear within "
4218                        "a DO block");
4219             break;
4220           case COMP_SELECT:
4221             gfc_error ("ENTRY statement at %C cannot appear within "
4222                        "a SELECT block");
4223             break;
4224           case COMP_FORALL:
4225             gfc_error ("ENTRY statement at %C cannot appear within "
4226                        "a FORALL block");
4227             break;
4228           case COMP_WHERE:
4229             gfc_error ("ENTRY statement at %C cannot appear within "
4230                        "a WHERE block");
4231             break;
4232           case COMP_CONTAINS:
4233             gfc_error ("ENTRY statement at %C cannot appear within "
4234                        "a contained subprogram");
4235             break;
4236           default:
4237             gfc_internal_error ("gfc_match_entry(): Bad state");
4238         }
4239       return MATCH_ERROR;
4240     }
4241
4242   module_procedure = gfc_current_ns->parent != NULL
4243                    && gfc_current_ns->parent->proc_name
4244                    && gfc_current_ns->parent->proc_name->attr.flavor
4245                       == FL_MODULE;
4246
4247   if (gfc_current_ns->parent != NULL
4248       && gfc_current_ns->parent->proc_name
4249       && !module_procedure)
4250     {
4251       gfc_error("ENTRY statement at %C cannot appear in a "
4252                 "contained procedure");
4253       return MATCH_ERROR;
4254     }
4255
4256   /* Module function entries need special care in get_proc_name
4257      because previous references within the function will have
4258      created symbols attached to the current namespace.  */
4259   if (get_proc_name (name, &entry,
4260                      gfc_current_ns->parent != NULL
4261                      && module_procedure
4262                      && gfc_current_ns->proc_name->attr.function))
4263     return MATCH_ERROR;
4264
4265   proc = gfc_current_block ();
4266
4267   if (state == COMP_SUBROUTINE)
4268     {
4269       /* An entry in a subroutine.  */
4270       if (!add_global_entry (name, 1))
4271         return MATCH_ERROR;
4272
4273       m = gfc_match_formal_arglist (entry, 0, 1);
4274       if (m != MATCH_YES)
4275         return MATCH_ERROR;
4276
4277       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4278           || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4279         return MATCH_ERROR;
4280     }
4281   else
4282     {
4283       /* An entry in a function.
4284          We need to take special care because writing
4285             ENTRY f()
4286          as
4287             ENTRY f
4288          is allowed, whereas
4289             ENTRY f() RESULT (r)
4290          can't be written as
4291             ENTRY f RESULT (r).  */
4292       if (!add_global_entry (name, 0))
4293         return MATCH_ERROR;
4294
4295       old_loc = gfc_current_locus;
4296       if (gfc_match_eos () == MATCH_YES)
4297         {
4298           gfc_current_locus = old_loc;
4299           /* Match the empty argument list, and add the interface to
4300              the symbol.  */
4301           m = gfc_match_formal_arglist (entry, 0, 1);
4302         }
4303       else
4304         m = gfc_match_formal_arglist (entry, 0, 0);
4305
4306       if (m != MATCH_YES)
4307         return MATCH_ERROR;
4308
4309       result = NULL;
4310
4311       if (gfc_match_eos () == MATCH_YES)
4312         {
4313           if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4314               || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4315             return MATCH_ERROR;
4316
4317           entry->result = entry;
4318         }
4319       else
4320         {
4321           m = match_result (proc, &result);
4322           if (m == MATCH_NO)
4323             gfc_syntax_error (ST_ENTRY);
4324           if (m != MATCH_YES)
4325             return MATCH_ERROR;
4326
4327           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
4328               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
4329               || gfc_add_function (&entry->attr, result->name, NULL)
4330                  == FAILURE)
4331             return MATCH_ERROR;
4332
4333           entry->result = result;
4334         }
4335     }
4336
4337   if (gfc_match_eos () != MATCH_YES)
4338     {
4339       gfc_syntax_error (ST_ENTRY);
4340       return MATCH_ERROR;
4341     }
4342
4343   entry->attr.recursive = proc->attr.recursive;
4344   entry->attr.elemental = proc->attr.elemental;
4345   entry->attr.pure = proc->attr.pure;
4346
4347   el = gfc_get_entry_list ();
4348   el->sym = entry;
4349   el->next = gfc_current_ns->entries;
4350   gfc_current_ns->entries = el;
4351   if (el->next)
4352     el->id = el->next->id + 1;
4353   else
4354     el->id = 1;
4355
4356   new_st.op = EXEC_ENTRY;
4357   new_st.ext.entry = el;
4358
4359   return MATCH_YES;
4360 }
4361
4362
4363 /* Match a subroutine statement, including optional prefixes.  */
4364
4365 match
4366 gfc_match_subroutine (void)
4367 {
4368   char name[GFC_MAX_SYMBOL_LEN + 1];
4369   gfc_symbol *sym;
4370   match m;
4371   match is_bind_c;
4372   char peek_char;
4373
4374   if (gfc_current_state () != COMP_NONE
4375       && gfc_current_state () != COMP_INTERFACE
4376       && gfc_current_state () != COMP_CONTAINS)
4377     return MATCH_NO;
4378
4379   m = match_prefix (NULL);
4380   if (m != MATCH_YES)
4381     return m;
4382
4383   m = gfc_match ("subroutine% %n", name);
4384   if (m != MATCH_YES)
4385     return m;
4386
4387   if (get_proc_name (name, &sym, false))
4388     return MATCH_ERROR;
4389   gfc_new_block = sym;
4390
4391   /* Check what next non-whitespace character is so we can tell if there
4392      where the required parens if we have a BIND(C).  */
4393   gfc_gobble_whitespace ();
4394   peek_char = gfc_peek_char ();
4395
4396   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4397     return MATCH_ERROR;
4398
4399   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4400     return MATCH_ERROR;
4401
4402   /* Make sure that it isn't already declared as BIND(C).  If it is, it
4403      must have been marked BIND(C) with a BIND(C) attribute and that is
4404      not allowed for procedures.  */
4405   if (sym->attr.is_bind_c == 1)
4406     {
4407       sym->attr.is_bind_c = 0;
4408       if (sym->old_symbol != NULL)
4409         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4410                        "variables or common blocks",
4411                        &(sym->old_symbol->declared_at));
4412       else
4413         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4414                        "variables or common blocks", &gfc_current_locus);
4415     }
4416
4417   /* Here, we are just checking if it has the bind(c) attribute, and if
4418      so, then we need to make sure it's all correct.  If it doesn't,
4419      we still need to continue matching the rest of the subroutine line.  */
4420   is_bind_c = gfc_match_bind_c (sym);
4421   if (is_bind_c == MATCH_ERROR)
4422     {
4423       /* There was an attempt at the bind(c), but it was wrong.  An
4424          error message should have been printed w/in the gfc_match_bind_c
4425          so here we'll just return the MATCH_ERROR.  */
4426       return MATCH_ERROR;
4427     }
4428
4429   if (is_bind_c == MATCH_YES)
4430     {
4431       if (peek_char != '(')
4432         {
4433           gfc_error ("Missing required parentheses before BIND(C) at %C");
4434           return MATCH_ERROR;
4435         }
4436       if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4437           == FAILURE)
4438         return MATCH_ERROR;
4439     }
4440
4441   if (gfc_match_eos () != MATCH_YES)
4442     {
4443       gfc_syntax_error (ST_SUBROUTINE);
4444       return MATCH_ERROR;
4445     }
4446
4447   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4448     return MATCH_ERROR;
4449
4450   return MATCH_YES;
4451 }
4452
4453
4454 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4455    given, and set the binding label in either the given symbol (if not
4456    NULL), or in the current_ts.  The symbol may be NULL because we may
4457    encounter the BIND(C) before the declaration itself.  Return
4458    MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4459    MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4460    or MATCH_YES if the specifier was correct and the binding label and
4461    bind(c) fields were set correctly for the given symbol or the
4462    current_ts.  */
4463
4464 match
4465 gfc_match_bind_c (gfc_symbol *sym)
4466 {
4467   /* binding label, if exists */
4468   char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4469   match double_quote;
4470   match single_quote;
4471
4472   /* Initialize the flag that specifies whether we encountered a NAME=
4473      specifier or not.  */
4474   has_name_equals = 0;
4475
4476   /* Init the first char to nil so we can catch if we don't have
4477      the label (name attr) or the symbol name yet.  */
4478   binding_label[0] = '\0';
4479
4480   /* This much we have to be able to match, in this order, if
4481      there is a bind(c) label.  */
4482   if (gfc_match (" bind ( c ") != MATCH_YES)
4483     return MATCH_NO;
4484
4485   /* Now see if there is a binding label, or if we've reached the
4486      end of the bind(c) attribute without one.  */
4487   if (gfc_match_char (',') == MATCH_YES)
4488     {
4489       if (gfc_match (" name = ") != MATCH_YES)
4490         {
4491           gfc_error ("Syntax error in NAME= specifier for binding label "
4492                      "at %C");
4493           /* should give an error message here */
4494           return MATCH_ERROR;
4495         }
4496
4497       has_name_equals = 1;
4498
4499       /* Get the opening quote.  */
4500       double_quote = MATCH_YES;
4501       single_quote = MATCH_YES;
4502       double_quote = gfc_match_char ('"');
4503       if (double_quote != MATCH_YES)
4504         single_quote = gfc_match_char ('\'');
4505       if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4506         {
4507           gfc_error ("Syntax error in NAME= specifier for binding label "
4508                      "at %C");
4509           return MATCH_ERROR;
4510         }
4511
4512       /* Grab the binding label, using functions that will not lower
4513          case the names automatically.  */
4514       if (gfc_match_name_C (binding_label) != MATCH_YES)
4515          return MATCH_ERROR;
4516
4517       /* Get the closing quotation.  */
4518       if (double_quote == MATCH_YES)
4519         {
4520           if (gfc_match_char ('"') != MATCH_YES)
4521             {
4522               gfc_error ("Missing closing quote '\"' for binding label at %C");
4523               /* User started string with '"' so looked to match it.  */
4524               return MATCH_ERROR;
4525             }
4526         }
4527       else
4528         {
4529           if (gfc_match_char ('\'') != MATCH_YES)
4530             {
4531               gfc_error ("Missing closing quote '\'' for binding label at %C");
4532               /* User started string with "'" char.  */
4533               return MATCH_ERROR;
4534             }
4535         }
4536    }
4537
4538   /* Get the required right paren.  */
4539   if (gfc_match_char (')') != MATCH_YES)
4540     {
4541       gfc_error ("Missing closing paren for binding label at %C");
4542       return MATCH_ERROR;
4543     }
4544
4545   /* Save the binding label to the symbol.  If sym is null, we're
4546      probably matching the typespec attributes of a declaration and
4547      haven't gotten the name yet, and therefore, no symbol yet.  */
4548   if (binding_label[0] != '\0')
4549     {
4550       if (sym != NULL)
4551       {
4552         strncpy (sym->binding_label, binding_label,
4553                  strlen (binding_label)+1);
4554       }
4555       else
4556         strncpy (curr_binding_label, binding_label,
4557                  strlen (binding_label) + 1);
4558     }
4559   else
4560     {
4561       /* No binding label, but if symbol isn't null, we
4562          can set the label for it here.  */
4563       /* TODO: If the name= was given and no binding label (name=""), we simply
4564          will let fortran mangle the symbol name as it usually would.
4565          However, this could still let C call it if the user looked up the
4566          symbol in the object file.  Should the name set during mangling in
4567          trans-decl.c be marked with characters that are invalid for C to
4568          prevent this?  */
4569       if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4570         strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4571     }
4572
4573   if (has_name_equals && gfc_current_state () == COMP_INTERFACE
4574       && current_interface.type == INTERFACE_ABSTRACT)
4575     {
4576       gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4577       return MATCH_ERROR;
4578     }
4579
4580   return MATCH_YES;
4581 }
4582
4583
4584 /* Return nonzero if we're currently compiling a contained procedure.  */
4585
4586 static int
4587 contained_procedure (void)
4588 {
4589   gfc_state_data *s;
4590
4591   for (s=gfc_state_stack; s; s=s->previous)
4592     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4593         && s->previous != NULL && s->previous->state == COMP_CONTAINS)
4594       return 1;
4595
4596   return 0;
4597 }
4598
4599 /* Set the kind of each enumerator.  The kind is selected such that it is
4600    interoperable with the corresponding C enumeration type, making
4601    sure that -fshort-enums is honored.  */
4602
4603 static void
4604 set_enum_kind(void)
4605 {
4606   enumerator_history *current_history = NULL;
4607   int kind;
4608   int i;
4609
4610   if (max_enum == NULL || enum_history == NULL)
4611     return;
4612
4613   if (!gfc_option.fshort_enums)
4614     return;
4615
4616   i = 0;
4617   do
4618     {
4619       kind = gfc_integer_kinds[i++].kind;
4620     }
4621   while (kind < gfc_c_int_kind
4622          && gfc_check_integer_range (max_enum->initializer->value.integer,
4623                                      kind) != ARITH_OK);
4624
4625   current_history = enum_history;
4626   while (current_history != NULL)
4627     {
4628       current_history->sym->ts.kind = kind;
4629       current_history = current_history->next;
4630     }
4631 }
4632
4633
4634 /* Match any of the various end-block statements.  Returns the type of
4635    END to the caller.  The END INTERFACE, END IF, END DO and END
4636    SELECT statements cannot be replaced by a single END statement.  */
4637
4638 match
4639 gfc_match_end (gfc_statement *st)
4640 {
4641   char name[GFC_MAX_SYMBOL_LEN + 1];
4642   gfc_compile_state state;
4643   locus old_loc;
4644   const char *block_name;
4645   const char *target;
4646   int eos_ok;
4647   match m;
4648
4649   old_loc = gfc_current_locus;
4650   if (gfc_match ("end") != MATCH_YES)
4651     return MATCH_NO;
4652
4653   state = gfc_current_state ();
4654   block_name = gfc_current_block () == NULL
4655              ? NULL : gfc_current_block ()->name;
4656
4657   if (state == COMP_CONTAINS)
4658     {
4659       state = gfc_state_stack->previous->state;
4660       block_name = gfc_state_stack->previous->sym == NULL
4661                  ? NULL : gfc_state_stack->previous->sym->name;
4662     }
4663
4664   switch (state)
4665     {
4666     case COMP_NONE:
4667     case COMP_PROGRAM:
4668       *st = ST_END_PROGRAM;
4669       target = " program";
4670       eos_ok = 1;
4671       break;
4672
4673     case COMP_SUBROUTINE:
4674       *st = ST_END_SUBROUTINE;
4675       target = " subroutine";
4676       eos_ok = !contained_procedure ();
4677       break;
4678
4679     case COMP_FUNCTION:
4680       *st = ST_END_FUNCTION;
4681       target = " function";
4682       eos_ok = !contained_procedure ();
4683       break;
4684
4685     case COMP_BLOCK_DATA:
4686       *st = ST_END_BLOCK_DATA;
4687       target = " block data";
4688       eos_ok = 1;
4689       break;
4690
4691     case COMP_MODULE:
4692       *st = ST_END_MODULE;
4693       target = " module";
4694       eos_ok = 1;
4695       break;
4696
4697     case COMP_INTERFACE:
4698       *st = ST_END_INTERFACE;
4699       target = " interface";
4700       eos_ok = 0;
4701       break;
4702
4703     case COMP_DERIVED:
4704       *st = ST_END_TYPE;
4705       target = " type";
4706       eos_ok = 0;
4707       break;
4708
4709     case COMP_IF:
4710       *st = ST_ENDIF;
4711       target = " if";
4712       eos_ok = 0;
4713       break;
4714
4715     case COMP_DO:
4716       *st = ST_ENDDO;
4717       target = " do";
4718       eos_ok = 0;
4719       break;
4720
4721     case COMP_SELECT:
4722       *st = ST_END_SELECT;
4723       target = " select";
4724       eos_ok = 0;
4725       break;
4726
4727     case COMP_FORALL:
4728       *st = ST_END_FORALL;
4729       target = " forall";
4730       eos_ok = 0;
4731       break;
4732
4733     case COMP_WHERE:
4734       *st = ST_END_WHERE;
4735       target = " where";
4736       eos_ok = 0;
4737       break;
4738
4739     case COMP_ENUM:
4740       *st = ST_END_ENUM;
4741       target = " enum";
4742       eos_ok = 0;
4743       last_initializer = NULL;
4744       set_enum_kind ();
4745       gfc_free_enum_history ();
4746       break;
4747
4748     default:
4749       gfc_error ("Unexpected END statement at %C");
4750       goto cleanup;
4751     }
4752
4753   if (gfc_match_eos () == MATCH_YES)
4754     {
4755       if (!eos_ok)
4756         {
4757           /* We would have required END [something].  */
4758           gfc_error ("%s statement expected at %L",
4759                      gfc_ascii_statement (*st), &old_loc);
4760           goto cleanup;
4761         }
4762
4763       return MATCH_YES;
4764     }
4765
4766   /* Verify that we've got the sort of end-block that we're expecting.  */
4767   if (gfc_match (target) != MATCH_YES)
4768     {
4769       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
4770       goto cleanup;
4771     }
4772
4773   /* If we're at the end, make sure a block name wasn't required.  */
4774   if (gfc_match_eos () == MATCH_YES)
4775     {
4776
4777       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
4778           && *st != ST_END_FORALL && *st != ST_END_WHERE)
4779         return MATCH_YES;
4780
4781       if (gfc_current_block () == NULL)
4782         return MATCH_YES;
4783
4784       gfc_error ("Expected block name of '%s' in %s statement at %C",
4785                  block_name, gfc_ascii_statement (*st));
4786
4787       return MATCH_ERROR;
4788     }
4789
4790   /* END INTERFACE has a special handler for its several possible endings.  */
4791   if (*st == ST_END_INTERFACE)
4792     return gfc_match_end_interface ();
4793
4794   /* We haven't hit the end of statement, so what is left must be an
4795      end-name.  */
4796   m = gfc_match_space ();
4797   if (m == MATCH_YES)
4798     m = gfc_match_name (name);
4799
4800   if (m == MATCH_NO)
4801     gfc_error ("Expected terminating name at %C");
4802   if (m != MATCH_YES)
4803     goto cleanup;
4804
4805   if (block_name == NULL)
4806     goto syntax;
4807
4808   if (strcmp (name, block_name) != 0)
4809     {
4810       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
4811                  gfc_ascii_statement (*st));
4812       goto cleanup;
4813     }
4814
4815   if (gfc_match_eos () == MATCH_YES)
4816     return MATCH_YES;
4817
4818 syntax:
4819   gfc_syntax_error (*st);
4820
4821 cleanup:
4822   gfc_current_locus = old_loc;
4823   return MATCH_ERROR;
4824 }
4825
4826
4827
4828 /***************** Attribute declaration statements ****************/
4829
4830 /* Set the attribute of a single variable.  */
4831
4832 static match
4833 attr_decl1 (void)
4834 {
4835   char name[GFC_MAX_SYMBOL_LEN + 1];
4836   gfc_array_spec *as;
4837   gfc_symbol *sym;
4838   locus var_locus;
4839   match m;
4840
4841   as = NULL;
4842
4843   m = gfc_match_name (name);
4844   if (m != MATCH_YES)
4845     goto cleanup;
4846
4847   if (find_special (name, &sym))
4848     return MATCH_ERROR;
4849
4850   var_locus = gfc_current_locus;
4851
4852   /* Deal with possible array specification for certain attributes.  */
4853   if (current_attr.dimension
4854       || current_attr.allocatable
4855       || current_attr.pointer
4856       || current_attr.target)
4857     {
4858       m = gfc_match_array_spec (&as);
4859       if (m == MATCH_ERROR)
4860         goto cleanup;
4861
4862       if (current_attr.dimension && m == MATCH_NO)
4863         {
4864           gfc_error ("Missing array specification at %L in DIMENSION "
4865                      "statement", &var_locus);
4866           m = MATCH_ERROR;
4867           goto cleanup;
4868         }
4869
4870       if ((current_attr.allocatable || current_attr.pointer)
4871           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
4872         {
4873           gfc_error ("Array specification must be deferred at %L", &var_locus);
4874           m = MATCH_ERROR;
4875           goto cleanup;
4876         }
4877     }
4878
4879   /* Update symbol table.  DIMENSION attribute is set
4880      in gfc_set_array_spec().  */
4881   if (current_attr.dimension == 0
4882       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
4883     {
4884       m = MATCH_ERROR;
4885       goto cleanup;
4886     }
4887
4888   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
4889     {
4890       m = MATCH_ERROR;
4891       goto cleanup;
4892     }
4893
4894   if (sym->attr.cray_pointee && sym->as != NULL)
4895     {
4896       /* Fix the array spec.  */
4897       m = gfc_mod_pointee_as (sym->as);
4898       if (m == MATCH_ERROR)
4899         goto cleanup;
4900     }
4901
4902   if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
4903     {
4904       m = MATCH_ERROR;
4905       goto cleanup;
4906     }
4907
4908   if ((current_attr.external || current_attr.intrinsic)
4909       && sym->attr.flavor != FL_PROCEDURE
4910       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
4911     {
4912       m = MATCH_ERROR;
4913       goto cleanup;
4914     }
4915
4916   return MATCH_YES;
4917
4918 cleanup:
4919   gfc_free_array_spec (as);
4920   return m;
4921 }
4922
4923
4924 /* Generic attribute declaration subroutine.  Used for attributes that
4925    just have a list of names.  */
4926
4927 static match
4928 attr_decl (void)
4929 {
4930   match m;
4931
4932   /* Gobble the optional double colon, by simply ignoring the result
4933      of gfc_match().  */
4934   gfc_match (" ::");
4935
4936   for (;;)
4937     {
4938       m = attr_decl1 ();
4939       if (m != MATCH_YES)
4940         break;
4941
4942       if (gfc_match_eos () == MATCH_YES)
4943         {
4944           m = MATCH_YES;
4945           break;
4946         }
4947
4948       if (gfc_match_char (',') != MATCH_YES)
4949         {
4950           gfc_error ("Unexpected character in variable list at %C");
4951           m = MATCH_ERROR;
4952           break;
4953         }
4954     }
4955
4956   return m;
4957 }
4958
4959
4960 /* This routine matches Cray Pointer declarations of the form:
4961    pointer ( <pointer>, <pointee> )
4962    or
4963    pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
4964    The pointer, if already declared, should be an integer.  Otherwise, we
4965    set it as BT_INTEGER with kind gfc_index_integer_kind.  The pointee may
4966    be either a scalar, or an array declaration.  No space is allocated for
4967    the pointee.  For the statement
4968    pointer (ipt, ar(10))
4969    any subsequent uses of ar will be translated (in C-notation) as
4970    ar(i) => ((<type> *) ipt)(i)
4971    After gimplification, pointee variable will disappear in the code.  */
4972
4973 static match
4974 cray_pointer_decl (void)
4975 {
4976   match m;
4977   gfc_array_spec *as;
4978   gfc_symbol *cptr; /* Pointer symbol.  */
4979   gfc_symbol *cpte; /* Pointee symbol.  */
4980   locus var_locus;
4981   bool done = false;
4982
4983   while (!done)
4984     {
4985       if (gfc_match_char ('(') != MATCH_YES)
4986         {
4987           gfc_error ("Expected '(' at %C");
4988           return MATCH_ERROR;
4989         }
4990
4991       /* Match pointer.  */
4992       var_locus = gfc_current_locus;
4993       gfc_clear_attr (&current_attr);
4994       gfc_add_cray_pointer (&current_attr, &var_locus);
4995       current_ts.type = BT_INTEGER;
4996       current_ts.kind = gfc_index_integer_kind;
4997
4998       m = gfc_match_symbol (&cptr, 0);
4999       if (m != MATCH_YES)
5000         {
5001           gfc_error ("Expected variable name at %C");
5002           return m;
5003         }
5004
5005       if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
5006         return MATCH_ERROR;
5007
5008       gfc_set_sym_referenced (cptr);
5009
5010       if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
5011         {
5012           cptr->ts.type = BT_INTEGER;
5013           cptr->ts.kind = gfc_index_integer_kind;
5014         }
5015       else if (cptr->ts.type != BT_INTEGER)
5016         {
5017           gfc_error ("Cray pointer at %C must be an integer");
5018           return MATCH_ERROR;
5019         }
5020       else if (cptr->ts.kind < gfc_index_integer_kind)
5021         gfc_warning ("Cray pointer at %C has %d bytes of precision;"
5022                      " memory addresses require %d bytes",
5023                      cptr->ts.kind, gfc_index_integer_kind);
5024
5025       if (gfc_match_char (',') != MATCH_YES)
5026         {
5027           gfc_error ("Expected \",\" at %C");
5028           return MATCH_ERROR;
5029         }
5030
5031       /* Match Pointee.  */
5032       var_locus = gfc_current_locus;
5033       gfc_clear_attr (&current_attr);
5034       gfc_add_cray_pointee (&current_attr, &var_locus);
5035       current_ts.type = BT_UNKNOWN;
5036       current_ts.kind = 0;
5037
5038       m = gfc_match_symbol (&cpte, 0);
5039       if (m != MATCH_YES)
5040         {
5041           gfc_error ("Expected variable name at %C");
5042           return m;
5043         }
5044
5045       /* Check for an optional array spec.  */
5046       m = gfc_match_array_spec (&as);
5047       if (m == MATCH_ERROR)
5048         {
5049           gfc_free_array_spec (as);
5050           return m;
5051         }
5052       else if (m == MATCH_NO)
5053         {
5054           gfc_free_array_spec (as);
5055           as = NULL;
5056         }
5057
5058       if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
5059         return MATCH_ERROR;
5060
5061       gfc_set_sym_referenced (cpte);
5062
5063       if (cpte->as == NULL)
5064         {
5065           if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
5066             gfc_internal_error ("Couldn't set Cray pointee array spec.");
5067         }
5068       else if (as != NULL)
5069         {
5070           gfc_error ("Duplicate array spec for Cray pointee at %C");
5071           gfc_free_array_spec (as);
5072           return MATCH_ERROR;
5073         }
5074
5075       as = NULL;
5076
5077       if (cpte->as != NULL)
5078         {
5079           /* Fix array spec.  */
5080           m = gfc_mod_pointee_as (cpte->as);
5081           if (m == MATCH_ERROR)
5082             return m;
5083         }
5084
5085       /* Point the Pointee at the Pointer.  */
5086       cpte->cp_pointer = cptr;
5087
5088       if (gfc_match_char (')') != MATCH_YES)
5089         {
5090           gfc_error ("Expected \")\" at %C");
5091           return MATCH_ERROR;
5092         }
5093       m = gfc_match_char (',');
5094       if (m != MATCH_YES)
5095         done = true; /* Stop searching for more declarations.  */
5096
5097     }
5098
5099   if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
5100       || gfc_match_eos () != MATCH_YES)
5101     {
5102       gfc_error ("Expected \",\" or end of statement at %C");
5103       return MATCH_ERROR;
5104     }
5105   return MATCH_YES;
5106 }
5107
5108
5109 match
5110 gfc_match_external (void)
5111 {
5112
5113   gfc_clear_attr (&current_attr);
5114   current_attr.external = 1;
5115
5116   return attr_decl ();
5117 }
5118
5119
5120 match
5121 gfc_match_intent (void)
5122 {
5123   sym_intent intent;
5124
5125   intent = match_intent_spec ();
5126   if (intent == INTENT_UNKNOWN)
5127     return MATCH_ERROR;
5128
5129   gfc_clear_attr (&current_attr);
5130   current_attr.intent = intent;
5131
5132   return attr_decl ();
5133 }
5134
5135
5136 match
5137 gfc_match_intrinsic (void)
5138 {
5139
5140   gfc_clear_attr (&current_attr);
5141   current_attr.intrinsic = 1;
5142
5143   return attr_decl ();
5144 }
5145
5146
5147 match
5148 gfc_match_optional (void)
5149 {
5150
5151   gfc_clear_attr (&current_attr);
5152   current_attr.optional = 1;
5153
5154   return attr_decl ();
5155 }
5156
5157
5158 match
5159 gfc_match_pointer (void)
5160 {
5161   gfc_gobble_whitespace ();
5162   if (gfc_peek_char () == '(')
5163     {
5164       if (!gfc_option.flag_cray_pointer)
5165         {
5166           gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
5167                      "flag");
5168           return MATCH_ERROR;
5169         }
5170       return cray_pointer_decl ();
5171     }
5172   else
5173     {
5174       gfc_clear_attr (&current_attr);
5175       current_attr.pointer = 1;
5176
5177       return attr_decl ();
5178     }
5179 }
5180
5181
5182 match
5183 gfc_match_allocatable (void)
5184 {
5185   gfc_clear_attr (&current_attr);
5186   current_attr.allocatable = 1;
5187
5188   return attr_decl ();
5189 }
5190
5191
5192 match
5193 gfc_match_dimension (void)
5194 {
5195   gfc_clear_attr (&current_attr);
5196   current_attr.dimension = 1;
5197
5198   return attr_decl ();
5199 }
5200
5201
5202 match
5203 gfc_match_target (void)
5204 {
5205   gfc_clear_attr (&current_attr);
5206   current_attr.target = 1;
5207
5208   return attr_decl ();
5209 }
5210
5211
5212 /* Match the list of entities being specified in a PUBLIC or PRIVATE
5213    statement.  */
5214
5215 static match
5216 access_attr_decl (gfc_statement st)
5217 {
5218   char name[GFC_MAX_SYMBOL_LEN + 1];
5219   interface_type type;
5220   gfc_user_op *uop;
5221   gfc_symbol *sym;
5222   gfc_intrinsic_op operator;
5223   match m;
5224
5225   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5226     goto done;
5227
5228   for (;;)
5229     {
5230       m = gfc_match_generic_spec (&type, name, &operator);
5231       if (m == MATCH_NO)
5232         goto syntax;
5233       if (m == MATCH_ERROR)
5234         return MATCH_ERROR;
5235
5236       switch (type)
5237         {
5238         case INTERFACE_NAMELESS:
5239         case INTERFACE_ABSTRACT:
5240           goto syntax;
5241
5242         case INTERFACE_GENERIC:
5243           if (gfc_get_symbol (name, NULL, &sym))
5244             goto done;
5245
5246           if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
5247                                           ? ACCESS_PUBLIC : ACCESS_PRIVATE,
5248                               sym->name, NULL) == FAILURE)
5249             return MATCH_ERROR;
5250
5251           break;
5252
5253         case INTERFACE_INTRINSIC_OP:
5254           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
5255             {
5256               gfc_current_ns->operator_access[operator] =
5257                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5258             }
5259           else
5260             {
5261               gfc_error ("Access specification of the %s operator at %C has "
5262                          "already been specified", gfc_op2string (operator));
5263               goto done;
5264             }
5265
5266           break;
5267
5268         case INTERFACE_USER_OP:
5269           uop = gfc_get_uop (name);
5270
5271           if (uop->access == ACCESS_UNKNOWN)
5272             {
5273               uop->access = (st == ST_PUBLIC)
5274                           ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5275             }
5276           else
5277             {
5278               gfc_error ("Access specification of the .%s. operator at %C "
5279                          "has already been specified", sym->name);
5280               goto done;
5281             }
5282
5283           break;
5284         }
5285
5286       if (gfc_match_char (',') == MATCH_NO)
5287         break;
5288     }
5289
5290   if (gfc_match_eos () != MATCH_YES)
5291     goto syntax;
5292   return MATCH_YES;
5293
5294 syntax:
5295   gfc_syntax_error (st);
5296
5297 done:
5298   return MATCH_ERROR;
5299 }
5300
5301
5302 match
5303 gfc_match_protected (void)
5304 {
5305   gfc_symbol *sym;
5306   match m;
5307
5308   if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5309     {
5310        gfc_error ("PROTECTED at %C only allowed in specification "
5311                   "part of a module");
5312        return MATCH_ERROR;
5313
5314     }
5315
5316   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
5317       == FAILURE)
5318     return MATCH_ERROR;
5319
5320   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5321     {
5322       return MATCH_ERROR;
5323     }
5324
5325   if (gfc_match_eos () == MATCH_YES)
5326     goto syntax;
5327
5328   for(;;)
5329     {
5330       m = gfc_match_symbol (&sym, 0);
5331       switch (m)
5332         {
5333         case MATCH_YES:
5334           if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
5335               == FAILURE)
5336             return MATCH_ERROR;
5337           goto next_item;
5338
5339         case MATCH_NO:
5340           break;
5341
5342         case MATCH_ERROR:
5343           return MATCH_ERROR;
5344         }
5345
5346     next_item:
5347       if (gfc_match_eos () == MATCH_YES)
5348         break;
5349       if (gfc_match_char (',') != MATCH_YES)
5350         goto syntax;
5351     }
5352
5353   return MATCH_YES;
5354
5355 syntax:
5356   gfc_error ("Syntax error in PROTECTED statement at %C");
5357   return MATCH_ERROR;
5358 }
5359
5360
5361 /* The PRIVATE statement is a bit weird in that it can be an attribute
5362    declaration, but also works as a standlone statement inside of a
5363    type declaration or a module.  */
5364
5365 match
5366 gfc_match_private (gfc_statement *st)
5367 {
5368
5369   if (gfc_match ("private") != MATCH_YES)
5370     return MATCH_NO;
5371
5372   if (gfc_current_state () != COMP_MODULE
5373       && (gfc_current_state () != COMP_DERIVED
5374           || !gfc_state_stack->previous
5375           || gfc_state_stack->previous->state != COMP_MODULE))
5376     {
5377       gfc_error ("PRIVATE statement at %C is only allowed in the "
5378                  "specification part of a module");
5379       return MATCH_ERROR;
5380     }
5381
5382   if (gfc_current_state () == COMP_DERIVED)
5383     {
5384       if (gfc_match_eos () == MATCH_YES)
5385         {
5386           *st = ST_PRIVATE;
5387           return MATCH_YES;
5388         }
5389
5390       gfc_syntax_error (ST_PRIVATE);
5391       return MATCH_ERROR;
5392     }
5393
5394   if (gfc_match_eos () == MATCH_YES)
5395     {
5396       *st = ST_PRIVATE;
5397       return MATCH_YES;
5398     }
5399
5400   *st = ST_ATTR_DECL;
5401   return access_attr_decl (ST_PRIVATE);
5402 }
5403
5404
5405 match
5406 gfc_match_public (gfc_statement *st)
5407 {
5408
5409   if (gfc_match ("public") != MATCH_YES)
5410     return MATCH_NO;
5411
5412   if (gfc_current_state () != COMP_MODULE)
5413     {
5414       gfc_error ("PUBLIC statement at %C is only allowed in the "
5415                  "specification part of a module");
5416       return MATCH_ERROR;
5417     }
5418
5419   if (gfc_match_eos () == MATCH_YES)
5420     {
5421       *st = ST_PUBLIC;
5422       return MATCH_YES;
5423     }
5424
5425   *st = ST_ATTR_DECL;
5426   return access_attr_decl (ST_PUBLIC);
5427 }
5428
5429
5430 /* Workhorse for gfc_match_parameter.  */
5431
5432 static match
5433 do_parm (void)
5434 {
5435   gfc_symbol *sym;
5436   gfc_expr *init;
5437   match m;
5438
5439   m = gfc_match_symbol (&sym, 0);
5440   if (m == MATCH_NO)
5441     gfc_error ("Expected variable name at %C in PARAMETER statement");
5442
5443   if (m != MATCH_YES)
5444     return m;
5445
5446   if (gfc_match_char ('=') == MATCH_NO)
5447     {
5448       gfc_error ("Expected = sign in PARAMETER statement at %C");
5449       return MATCH_ERROR;
5450     }
5451
5452   m = gfc_match_init_expr (&init);
5453   if (m == MATCH_NO)
5454     gfc_error ("Expected expression at %C in PARAMETER statement");
5455   if (m != MATCH_YES)
5456     return m;
5457
5458   if (sym->ts.type == BT_UNKNOWN
5459       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5460     {
5461       m = MATCH_ERROR;
5462       goto cleanup;
5463     }
5464
5465   if (gfc_check_assign_symbol (sym, init) == FAILURE
5466       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
5467     {
5468       m = MATCH_ERROR;
5469       goto cleanup;
5470     }
5471
5472   if (sym->ts.type == BT_CHARACTER
5473       && sym->ts.cl != NULL
5474       && sym->ts.cl->length != NULL
5475       && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5476       && init->expr_type == EXPR_CONSTANT
5477       && init->ts.type == BT_CHARACTER
5478       && init->ts.kind == 1)
5479     gfc_set_constant_character_len (
5480       mpz_get_si (sym->ts.cl->length->value.integer), init, false);
5481
5482   sym->value = init;
5483   return MATCH_YES;
5484
5485 cleanup:
5486   gfc_free_expr (init);
5487   return m;
5488 }
5489
5490
5491 /* Match a parameter statement, with the weird syntax that these have.  */
5492
5493 match
5494 gfc_match_parameter (void)
5495 {
5496   match m;
5497
5498   if (gfc_match_char ('(') == MATCH_NO)
5499     return MATCH_NO;
5500
5501   for (;;)
5502     {
5503       m = do_parm ();
5504       if (m != MATCH_YES)
5505         break;
5506
5507       if (gfc_match (" )%t") == MATCH_YES)
5508         break;
5509
5510       if (gfc_match_char (',') != MATCH_YES)
5511         {
5512           gfc_error ("Unexpected characters in PARAMETER statement at %C");
5513           m = MATCH_ERROR;
5514           break;
5515         }
5516     }
5517
5518   return m;
5519 }
5520
5521
5522 /* Save statements have a special syntax.  */
5523
5524 match
5525 gfc_match_save (void)
5526 {
5527   char n[GFC_MAX_SYMBOL_LEN+1];
5528   gfc_common_head *c;
5529   gfc_symbol *sym;
5530   match m;
5531
5532   if (gfc_match_eos () == MATCH_YES)
5533     {
5534       if (gfc_current_ns->seen_save)
5535         {
5536           if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5537                               "follows previous SAVE statement")
5538               == FAILURE)
5539             return MATCH_ERROR;
5540         }
5541
5542       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5543       return MATCH_YES;
5544     }
5545
5546   if (gfc_current_ns->save_all)
5547     {
5548       if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5549                           "blanket SAVE statement")
5550           == FAILURE)
5551         return MATCH_ERROR;
5552     }
5553
5554   gfc_match (" ::");
5555
5556   for (;;)
5557     {
5558       m = gfc_match_symbol (&sym, 0);
5559       switch (m)
5560         {
5561         case MATCH_YES:
5562           if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
5563               == FAILURE)
5564             return MATCH_ERROR;
5565           goto next_item;
5566
5567         case MATCH_NO:
5568           break;
5569
5570         case MATCH_ERROR:
5571           return MATCH_ERROR;
5572         }
5573
5574       m = gfc_match (" / %n /", &n);
5575       if (m == MATCH_ERROR)
5576         return MATCH_ERROR;
5577       if (m == MATCH_NO)
5578         goto syntax;
5579
5580       c = gfc_get_common (n, 0);
5581       c->saved = 1;
5582
5583       gfc_current_ns->seen_save = 1;
5584
5585     next_item:
5586       if (gfc_match_eos () == MATCH_YES)
5587         break;
5588       if (gfc_match_char (',') != MATCH_YES)
5589         goto syntax;
5590     }
5591
5592   return MATCH_YES;
5593
5594 syntax:
5595   gfc_error ("Syntax error in SAVE statement at %C");
5596   return MATCH_ERROR;
5597 }
5598
5599
5600 match
5601 gfc_match_value (void)
5602 {
5603   gfc_symbol *sym;
5604   match m;
5605
5606   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
5607       == FAILURE)
5608     return MATCH_ERROR;
5609
5610   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5611     {
5612       return MATCH_ERROR;
5613     }
5614
5615   if (gfc_match_eos () == MATCH_YES)
5616     goto syntax;
5617
5618   for(;;)
5619     {
5620       m = gfc_match_symbol (&sym, 0);
5621       switch (m)
5622         {
5623         case MATCH_YES:
5624           if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
5625               == FAILURE)
5626             return MATCH_ERROR;
5627           goto next_item;
5628
5629         case MATCH_NO:
5630           break;
5631
5632         case MATCH_ERROR:
5633           return MATCH_ERROR;
5634         }
5635
5636     next_item:
5637       if (gfc_match_eos () == MATCH_YES)
5638         break;
5639       if (gfc_match_char (',') != MATCH_YES)
5640         goto syntax;
5641     }
5642
5643   return MATCH_YES;
5644
5645 syntax:
5646   gfc_error ("Syntax error in VALUE statement at %C");
5647   return MATCH_ERROR;
5648 }
5649
5650
5651 match
5652 gfc_match_volatile (void)
5653 {
5654   gfc_symbol *sym;
5655   match m;
5656
5657   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
5658       == FAILURE)
5659     return MATCH_ERROR;
5660
5661   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5662     {
5663       return MATCH_ERROR;
5664     }
5665
5666   if (gfc_match_eos () == MATCH_YES)
5667     goto syntax;
5668
5669   for(;;)
5670     {
5671       /* VOLATILE is special because it can be added to host-associated
5672          symbols locally.  */
5673       m = gfc_match_symbol (&sym, 1);
5674       switch (m)
5675         {
5676         case MATCH_YES:
5677           if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
5678               == FAILURE)
5679             return MATCH_ERROR;
5680           goto next_item;
5681
5682         case MATCH_NO:
5683           break;
5684
5685         case MATCH_ERROR:
5686           return MATCH_ERROR;
5687         }
5688
5689     next_item:
5690       if (gfc_match_eos () == MATCH_YES)
5691         break;
5692       if (gfc_match_char (',') != MATCH_YES)
5693         goto syntax;
5694     }
5695
5696   return MATCH_YES;
5697
5698 syntax:
5699   gfc_error ("Syntax error in VOLATILE statement at %C");
5700   return MATCH_ERROR;
5701 }
5702
5703
5704 /* Match a module procedure statement.  Note that we have to modify
5705    symbols in the parent's namespace because the current one was there
5706    to receive symbols that are in an interface's formal argument list.  */
5707
5708 match
5709 gfc_match_modproc (void)
5710 {
5711   char name[GFC_MAX_SYMBOL_LEN + 1];
5712   gfc_symbol *sym;
5713   match m;
5714   gfc_namespace *module_ns;
5715
5716   if (gfc_state_stack->state != COMP_INTERFACE
5717       || gfc_state_stack->previous == NULL
5718       || current_interface.type == INTERFACE_NAMELESS
5719       || current_interface.type == INTERFACE_ABSTRACT)
5720     {
5721       gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5722                  "interface");
5723       return MATCH_ERROR;
5724     }
5725
5726   module_ns = gfc_current_ns->parent;
5727   for (; module_ns; module_ns = module_ns->parent)
5728     if (module_ns->proc_name->attr.flavor == FL_MODULE)
5729       break;
5730
5731   if (module_ns == NULL)
5732     return MATCH_ERROR;
5733
5734   for (;;)
5735     {
5736       m = gfc_match_name (name);
5737       if (m == MATCH_NO)
5738         goto syntax;
5739       if (m != MATCH_YES)
5740         return MATCH_ERROR;
5741
5742       if (gfc_get_symbol (name, module_ns, &sym))
5743         return MATCH_ERROR;
5744
5745       if (sym->attr.proc != PROC_MODULE
5746           && gfc_add_procedure (&sym->attr, PROC_MODULE,
5747                                 sym->name, NULL) == FAILURE)
5748         return MATCH_ERROR;
5749
5750       if (gfc_add_interface (sym) == FAILURE)
5751         return MATCH_ERROR;
5752
5753       sym->attr.mod_proc = 1;
5754
5755       if (gfc_match_eos () == MATCH_YES)
5756         break;
5757       if (gfc_match_char (',') != MATCH_YES)
5758         goto syntax;
5759     }
5760
5761   return MATCH_YES;
5762
5763 syntax:
5764   gfc_syntax_error (ST_MODULE_PROC);
5765   return MATCH_ERROR;
5766 }
5767
5768
5769 /* Match the optional attribute specifiers for a type declaration.
5770    Return MATCH_ERROR if an error is encountered in one of the handled
5771    attributes (public, private, bind(c)), MATCH_NO if what's found is
5772    not a handled attribute, and MATCH_YES otherwise.  TODO: More error
5773    checking on attribute conflicts needs to be done.  */
5774
5775 match
5776 gfc_get_type_attr_spec (symbol_attribute *attr)
5777 {
5778   /* See if the derived type is marked as private.  */
5779   if (gfc_match (" , private") == MATCH_YES)
5780     {
5781       if (gfc_current_state () != COMP_MODULE)
5782         {
5783           gfc_error ("Derived type at %C can only be PRIVATE in the "
5784                      "specification part of a module");
5785           return MATCH_ERROR;
5786         }
5787
5788       if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
5789         return MATCH_ERROR;
5790     }
5791   else if (gfc_match (" , public") == MATCH_YES)
5792     {
5793       if (gfc_current_state () != COMP_MODULE)
5794         {
5795           gfc_error ("Derived type at %C can only be PUBLIC in the "
5796                      "specification part of a module");
5797           return MATCH_ERROR;
5798         }
5799
5800       if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
5801         return MATCH_ERROR;
5802     }
5803   else if (gfc_match(" , bind ( c )") == MATCH_YES)
5804     {
5805       /* If the type is defined to be bind(c) it then needs to make
5806          sure that all fields are interoperable.  This will
5807          need to be a semantic check on the finished derived type.
5808          See 15.2.3 (lines 9-12) of F2003 draft.  */
5809       if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
5810         return MATCH_ERROR;
5811
5812       /* TODO: attr conflicts need to be checked, probably in symbol.c.  */
5813     }
5814   else
5815     return MATCH_NO;
5816
5817   /* If we get here, something matched.  */
5818   return MATCH_YES;
5819 }
5820
5821
5822 /* Match the beginning of a derived type declaration.  If a type name
5823    was the result of a function, then it is possible to have a symbol
5824    already to be known as a derived type yet have no components.  */
5825
5826 match
5827 gfc_match_derived_decl (void)
5828 {
5829   char name[GFC_MAX_SYMBOL_LEN + 1];
5830   symbol_attribute attr;
5831   gfc_symbol *sym;
5832   match m;
5833   match is_type_attr_spec = MATCH_NO;
5834   bool seen_attr = false;
5835
5836   if (gfc_current_state () == COMP_DERIVED)
5837     return MATCH_NO;
5838
5839   gfc_clear_attr (&attr);
5840
5841   do
5842     {
5843       is_type_attr_spec = gfc_get_type_attr_spec (&attr);
5844       if (is_type_attr_spec == MATCH_ERROR)
5845         return MATCH_ERROR;
5846       if (is_type_attr_spec == MATCH_YES)
5847         seen_attr = true;
5848     } while (is_type_attr_spec == MATCH_YES);
5849
5850   if (gfc_match (" ::") != MATCH_YES && seen_attr)
5851     {
5852       gfc_error ("Expected :: in TYPE definition at %C");
5853       return MATCH_ERROR;
5854     }
5855
5856   m = gfc_match (" %n%t", name);
5857   if (m != MATCH_YES)
5858     return m;
5859
5860   /* Make sure the name is not the name of an intrinsic type.  */
5861   if (gfc_is_intrinsic_typename (name))
5862     {
5863       gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5864                  "type", name);
5865       return MATCH_ERROR;
5866     }
5867
5868   if (gfc_get_symbol (name, NULL, &sym))
5869     return MATCH_ERROR;
5870
5871   if (sym->ts.type != BT_UNKNOWN)
5872     {
5873       gfc_error ("Derived type name '%s' at %C already has a basic type "
5874                  "of %s", sym->name, gfc_typename (&sym->ts));
5875       return MATCH_ERROR;
5876     }
5877
5878   /* The symbol may already have the derived attribute without the
5879      components.  The ways this can happen is via a function
5880      definition, an INTRINSIC statement or a subtype in another
5881      derived type that is a pointer.  The first part of the AND clause
5882      is true if a the symbol is not the return value of a function.  */
5883   if (sym->attr.flavor != FL_DERIVED
5884       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
5885     return MATCH_ERROR;
5886
5887   if (sym->components != NULL)
5888     {
5889       gfc_error ("Derived type definition of '%s' at %C has already been "
5890                  "defined", sym->name);
5891       return MATCH_ERROR;
5892     }
5893
5894   if (attr.access != ACCESS_UNKNOWN
5895       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
5896     return MATCH_ERROR;
5897
5898   /* See if the derived type was labeled as bind(c).  */
5899   if (attr.is_bind_c != 0)
5900     sym->attr.is_bind_c = attr.is_bind_c;
5901
5902   gfc_new_block = sym;
5903
5904   return MATCH_YES;
5905 }
5906
5907
5908 /* Cray Pointees can be declared as:
5909       pointer (ipt, a (n,m,...,*))
5910    By default, this is treated as an AS_ASSUMED_SIZE array.  We'll
5911    cheat and set a constant bound of 1 for the last dimension, if this
5912    is the case. Since there is no bounds-checking for Cray Pointees,
5913    this will be okay.  */
5914
5915 try
5916 gfc_mod_pointee_as (gfc_array_spec *as)
5917 {
5918   as->cray_pointee = true; /* This will be useful to know later.  */
5919   if (as->type == AS_ASSUMED_SIZE)
5920     {
5921       as->type = AS_EXPLICIT;
5922       as->upper[as->rank - 1] = gfc_int_expr (1);
5923       as->cp_was_assumed = true;
5924     }
5925   else if (as->type == AS_ASSUMED_SHAPE)
5926     {
5927       gfc_error ("Cray Pointee at %C cannot be assumed shape array");
5928       return MATCH_ERROR;
5929     }
5930   return MATCH_YES;
5931 }
5932
5933
5934 /* Match the enum definition statement, here we are trying to match
5935    the first line of enum definition statement.
5936    Returns MATCH_YES if match is found.  */
5937
5938 match
5939 gfc_match_enum (void)
5940 {
5941   match m;
5942
5943   m = gfc_match_eos ();
5944   if (m != MATCH_YES)
5945     return m;
5946
5947   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
5948       == FAILURE)
5949     return MATCH_ERROR;
5950
5951   return MATCH_YES;
5952 }
5953
5954
5955 /* Match a variable name with an optional initializer.  When this
5956    subroutine is called, a variable is expected to be parsed next.
5957    Depending on what is happening at the moment, updates either the
5958    symbol table or the current interface.  */
5959
5960 static match
5961 enumerator_decl (void)
5962 {
5963   char name[GFC_MAX_SYMBOL_LEN + 1];
5964   gfc_expr *initializer;
5965   gfc_array_spec *as = NULL;
5966   gfc_symbol *sym;
5967   locus var_locus;
5968   match m;
5969   try t;
5970   locus old_locus;
5971
5972   initializer = NULL;
5973   old_locus = gfc_current_locus;
5974
5975   /* When we get here, we've just matched a list of attributes and
5976      maybe a type and a double colon.  The next thing we expect to see
5977      is the name of the symbol.  */
5978   m = gfc_match_name (name);
5979   if (m != MATCH_YES)
5980     goto cleanup;
5981
5982   var_locus = gfc_current_locus;
5983
5984   /* OK, we've successfully matched the declaration.  Now put the
5985      symbol in the current namespace. If we fail to create the symbol,
5986      bail out.  */
5987   if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
5988     {
5989       m = MATCH_ERROR;
5990       goto cleanup;
5991     }
5992
5993   /* The double colon must be present in order to have initializers.
5994      Otherwise the statement is ambiguous with an assignment statement.  */
5995   if (colon_seen)
5996     {
5997       if (gfc_match_char ('=') == MATCH_YES)
5998         {
5999           m = gfc_match_init_expr (&initializer);
6000           if (m == MATCH_NO)
6001             {
6002               gfc_error ("Expected an initialization expression at %C");
6003               m = MATCH_ERROR;
6004             }
6005
6006           if (m != MATCH_YES)
6007             goto cleanup;
6008         }
6009     }
6010
6011   /* If we do not have an initializer, the initialization value of the
6012      previous enumerator (stored in last_initializer) is incremented
6013      by 1 and is used to initialize the current enumerator.  */
6014   if (initializer == NULL)
6015     initializer = gfc_enum_initializer (last_initializer, old_locus);
6016
6017   if (initializer == NULL || initializer->ts.type != BT_INTEGER)
6018     {
6019       gfc_error("ENUMERATOR %L not initialized with integer expression",
6020                 &var_locus);
6021       m = MATCH_ERROR;
6022       gfc_free_enum_history ();
6023       goto cleanup;
6024     }
6025
6026   /* Store this current initializer, for the next enumerator variable
6027      to be parsed.  add_init_expr_to_sym() zeros initializer, so we
6028      use last_initializer below.  */
6029   last_initializer = initializer;
6030   t = add_init_expr_to_sym (name, &initializer, &var_locus);
6031
6032   /* Maintain enumerator history.  */
6033   gfc_find_symbol (name, NULL, 0, &sym);
6034   create_enum_history (sym, last_initializer);
6035
6036   return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
6037
6038 cleanup:
6039   /* Free stuff up and return.  */
6040   gfc_free_expr (initializer);
6041
6042   return m;
6043 }
6044
6045
6046 /* Match the enumerator definition statement.  */
6047
6048 match
6049 gfc_match_enumerator_def (void)
6050 {
6051   match m;
6052   try t;
6053
6054   gfc_clear_ts (&current_ts);
6055
6056   m = gfc_match (" enumerator");
6057   if (m != MATCH_YES)
6058     return m;
6059
6060   m = gfc_match (" :: ");
6061   if (m == MATCH_ERROR)
6062     return m;
6063
6064   colon_seen = (m == MATCH_YES);
6065
6066   if (gfc_current_state () != COMP_ENUM)
6067     {
6068       gfc_error ("ENUM definition statement expected before %C");
6069       gfc_free_enum_history ();
6070       return MATCH_ERROR;
6071     }
6072
6073   (&current_ts)->type = BT_INTEGER;
6074   (&current_ts)->kind = gfc_c_int_kind;
6075
6076   gfc_clear_attr (&current_attr);
6077   t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
6078   if (t == FAILURE)
6079     {
6080       m = MATCH_ERROR;
6081       goto cleanup;
6082     }
6083
6084   for (;;)
6085     {
6086       m = enumerator_decl ();
6087       if (m == MATCH_ERROR)
6088         goto cleanup;
6089       if (m == MATCH_NO)
6090         break;
6091
6092       if (gfc_match_eos () == MATCH_YES)
6093         goto cleanup;
6094       if (gfc_match_char (',') != MATCH_YES)
6095         break;
6096     }
6097
6098   if (gfc_current_state () == COMP_ENUM)
6099     {
6100       gfc_free_enum_history ();
6101       gfc_error ("Syntax error in ENUMERATOR definition at %C");
6102       m = MATCH_ERROR;
6103     }
6104
6105 cleanup:
6106   gfc_free_array_spec (current_as);
6107   current_as = NULL;
6108   return m;
6109
6110 }
6111