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       && !current_ts.derived->attr.zero_comp)
3419     {
3420
3421       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3422         goto ok;
3423
3424       gfc_find_symbol (current_ts.derived->name,
3425                        current_ts.derived->ns->parent, 1, &sym);
3426
3427       /* Any symbol that we find had better be a type definition
3428          which has its components defined.  */
3429       if (sym != NULL && sym->attr.flavor == FL_DERIVED
3430           && (current_ts.derived->components != NULL
3431               || current_ts.derived->attr.zero_comp))
3432         goto ok;
3433
3434       /* Now we have an error, which we signal, and then fix up
3435          because the knock-on is plain and simple confusing.  */
3436       gfc_error_now ("Derived type at %C has not been previously defined "
3437                      "and so cannot appear in a derived type definition");
3438       current_attr.pointer = 1;
3439       goto ok;
3440     }
3441
3442 ok:
3443   /* If we have an old-style character declaration, and no new-style
3444      attribute specifications, then there a comma is optional between
3445      the type specification and the variable list.  */
3446   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3447     gfc_match_char (',');
3448
3449   /* Give the types/attributes to symbols that follow. Give the element
3450      a number so that repeat character length expressions can be copied.  */
3451   elem = 1;
3452   for (;;)
3453     {
3454       num_idents_on_line++;
3455       m = variable_decl (elem++);
3456       if (m == MATCH_ERROR)
3457         goto cleanup;
3458       if (m == MATCH_NO)
3459         break;
3460
3461       if (gfc_match_eos () == MATCH_YES)
3462         goto cleanup;
3463       if (gfc_match_char (',') != MATCH_YES)
3464         break;
3465     }
3466
3467   if (gfc_error_flag_test () == 0)
3468     gfc_error ("Syntax error in data declaration at %C");
3469   m = MATCH_ERROR;
3470
3471   gfc_free_data_all (gfc_current_ns);
3472
3473 cleanup:
3474   gfc_free_array_spec (current_as);
3475   current_as = NULL;
3476   return m;
3477 }
3478
3479
3480 /* Match a prefix associated with a function or subroutine
3481    declaration.  If the typespec pointer is nonnull, then a typespec
3482    can be matched.  Note that if nothing matches, MATCH_YES is
3483    returned (the null string was matched).  */
3484
3485 static match
3486 match_prefix (gfc_typespec *ts)
3487 {
3488   int seen_type;
3489
3490   gfc_clear_attr (&current_attr);
3491   seen_type = 0;
3492
3493 loop:
3494   if (!seen_type && ts != NULL
3495       && match_type_spec (ts, 0) == MATCH_YES
3496       && gfc_match_space () == MATCH_YES)
3497     {
3498
3499       seen_type = 1;
3500       goto loop;
3501     }
3502
3503   if (gfc_match ("elemental% ") == MATCH_YES)
3504     {
3505       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3506         return MATCH_ERROR;
3507
3508       goto loop;
3509     }
3510
3511   if (gfc_match ("pure% ") == MATCH_YES)
3512     {
3513       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3514         return MATCH_ERROR;
3515
3516       goto loop;
3517     }
3518
3519   if (gfc_match ("recursive% ") == MATCH_YES)
3520     {
3521       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3522         return MATCH_ERROR;
3523
3524       goto loop;
3525     }
3526
3527   /* At this point, the next item is not a prefix.  */
3528   return MATCH_YES;
3529 }
3530
3531
3532 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
3533
3534 static try
3535 copy_prefix (symbol_attribute *dest, locus *where)
3536 {
3537   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3538     return FAILURE;
3539
3540   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3541     return FAILURE;
3542
3543   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3544     return FAILURE;
3545
3546   return SUCCESS;
3547 }
3548
3549
3550 /* Match a formal argument list.  */
3551
3552 match
3553 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3554 {
3555   gfc_formal_arglist *head, *tail, *p, *q;
3556   char name[GFC_MAX_SYMBOL_LEN + 1];
3557   gfc_symbol *sym;
3558   match m;
3559
3560   head = tail = NULL;
3561
3562   if (gfc_match_char ('(') != MATCH_YES)
3563     {
3564       if (null_flag)
3565         goto ok;
3566       return MATCH_NO;
3567     }
3568
3569   if (gfc_match_char (')') == MATCH_YES)
3570     goto ok;
3571
3572   for (;;)
3573     {
3574       if (gfc_match_char ('*') == MATCH_YES)
3575         sym = NULL;
3576       else
3577         {
3578           m = gfc_match_name (name);
3579           if (m != MATCH_YES)
3580             goto cleanup;
3581
3582           if (gfc_get_symbol (name, NULL, &sym))
3583             goto cleanup;
3584         }
3585
3586       p = gfc_get_formal_arglist ();
3587
3588       if (head == NULL)
3589         head = tail = p;
3590       else
3591         {
3592           tail->next = p;
3593           tail = p;
3594         }
3595
3596       tail->sym = sym;
3597
3598       /* We don't add the VARIABLE flavor because the name could be a
3599          dummy procedure.  We don't apply these attributes to formal
3600          arguments of statement functions.  */
3601       if (sym != NULL && !st_flag
3602           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3603               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3604         {
3605           m = MATCH_ERROR;
3606           goto cleanup;
3607         }
3608
3609       /* The name of a program unit can be in a different namespace,
3610          so check for it explicitly.  After the statement is accepted,
3611          the name is checked for especially in gfc_get_symbol().  */
3612       if (gfc_new_block != NULL && sym != NULL
3613           && strcmp (sym->name, gfc_new_block->name) == 0)
3614         {
3615           gfc_error ("Name '%s' at %C is the name of the procedure",
3616                      sym->name);
3617           m = MATCH_ERROR;
3618           goto cleanup;
3619         }
3620
3621       if (gfc_match_char (')') == MATCH_YES)
3622         goto ok;
3623
3624       m = gfc_match_char (',');
3625       if (m != MATCH_YES)
3626         {
3627           gfc_error ("Unexpected junk in formal argument list at %C");
3628           goto cleanup;
3629         }
3630     }
3631
3632 ok:
3633   /* Check for duplicate symbols in the formal argument list.  */
3634   if (head != NULL)
3635     {
3636       for (p = head; p->next; p = p->next)
3637         {
3638           if (p->sym == NULL)
3639             continue;
3640
3641           for (q = p->next; q; q = q->next)
3642             if (p->sym == q->sym)
3643               {
3644                 gfc_error ("Duplicate symbol '%s' in formal argument list "
3645                            "at %C", p->sym->name);
3646
3647                 m = MATCH_ERROR;
3648                 goto cleanup;
3649               }
3650         }
3651     }
3652
3653   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3654       == FAILURE)
3655     {
3656       m = MATCH_ERROR;
3657       goto cleanup;
3658     }
3659
3660   return MATCH_YES;
3661
3662 cleanup:
3663   gfc_free_formal_arglist (head);
3664   return m;
3665 }
3666
3667
3668 /* Match a RESULT specification following a function declaration or
3669    ENTRY statement.  Also matches the end-of-statement.  */
3670
3671 static match
3672 match_result (gfc_symbol *function, gfc_symbol **result)
3673 {
3674   char name[GFC_MAX_SYMBOL_LEN + 1];
3675   gfc_symbol *r;
3676   match m;
3677
3678   if (gfc_match (" result (") != MATCH_YES)
3679     return MATCH_NO;
3680
3681   m = gfc_match_name (name);
3682   if (m != MATCH_YES)
3683     return m;
3684
3685   /* Get the right paren, and that's it because there could be the
3686      bind(c) attribute after the result clause.  */
3687   if (gfc_match_char(')') != MATCH_YES)
3688     {
3689      /* TODO: should report the missing right paren here.  */
3690       return MATCH_ERROR;
3691     }
3692
3693   if (strcmp (function->name, name) == 0)
3694     {
3695       gfc_error ("RESULT variable at %C must be different than function name");
3696       return MATCH_ERROR;
3697     }
3698
3699   if (gfc_get_symbol (name, NULL, &r))
3700     return MATCH_ERROR;
3701
3702   if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3703       || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3704     return MATCH_ERROR;
3705
3706   *result = r;
3707
3708   return MATCH_YES;
3709 }
3710
3711
3712 /* Match a function suffix, which could be a combination of a result
3713    clause and BIND(C), either one, or neither.  The draft does not
3714    require them to come in a specific order.  */
3715
3716 match
3717 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3718 {
3719   match is_bind_c;   /* Found bind(c).  */
3720   match is_result;   /* Found result clause.  */
3721   match found_match; /* Status of whether we've found a good match.  */
3722   int peek_char;     /* Character we're going to peek at.  */
3723
3724   /* Initialize to having found nothing.  */
3725   found_match = MATCH_NO;
3726   is_bind_c = MATCH_NO;
3727   is_result = MATCH_NO;
3728
3729   /* Get the next char to narrow between result and bind(c).  */
3730   gfc_gobble_whitespace ();
3731   peek_char = gfc_peek_char ();
3732
3733   switch (peek_char)
3734     {
3735     case 'r':
3736       /* Look for result clause.  */
3737       is_result = match_result (sym, result);
3738       if (is_result == MATCH_YES)
3739         {
3740           /* Now see if there is a bind(c) after it.  */
3741           is_bind_c = gfc_match_bind_c (sym);
3742           /* We've found the result clause and possibly bind(c).  */
3743           found_match = MATCH_YES;
3744         }
3745       else
3746         /* This should only be MATCH_ERROR.  */
3747         found_match = is_result;
3748       break;
3749     case 'b':
3750       /* Look for bind(c) first.  */
3751       is_bind_c = gfc_match_bind_c (sym);
3752       if (is_bind_c == MATCH_YES)
3753         {
3754           /* Now see if a result clause followed it.  */
3755           is_result = match_result (sym, result);
3756           found_match = MATCH_YES;
3757         }
3758       else
3759         {
3760           /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
3761           found_match = MATCH_ERROR;
3762         }
3763       break;
3764     default:
3765       gfc_error ("Unexpected junk after function declaration at %C");
3766       found_match = MATCH_ERROR;
3767       break;
3768     }
3769
3770   if (is_bind_c == MATCH_YES)
3771     if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3772         == FAILURE)
3773       return MATCH_ERROR;
3774
3775   return found_match;
3776 }
3777
3778
3779 /* Match a PROCEDURE declaration (R1211).  */
3780
3781 static match
3782 match_procedure_decl (void)
3783 {
3784   match m;
3785   locus old_loc, entry_loc;
3786   gfc_symbol *sym, *proc_if = NULL;
3787   int num;
3788
3789   old_loc = entry_loc = gfc_current_locus;
3790
3791   gfc_clear_ts (&current_ts);
3792
3793   if (gfc_match (" (") != MATCH_YES)
3794     {
3795       gfc_current_locus = entry_loc;
3796       return MATCH_NO;
3797     }
3798
3799   /* Get the type spec. for the procedure interface.  */
3800   old_loc = gfc_current_locus;
3801   m = match_type_spec (&current_ts, 0);
3802   if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
3803     goto got_ts;
3804
3805   if (m == MATCH_ERROR)
3806     return m;
3807
3808   gfc_current_locus = old_loc;
3809
3810   /* Get the name of the procedure or abstract interface
3811   to inherit the interface from.  */
3812   m = gfc_match_symbol (&proc_if, 1);
3813
3814   if (m == MATCH_NO)
3815     goto syntax;
3816   else if (m == MATCH_ERROR)
3817     return m;
3818
3819   /* Various interface checks.  */
3820   if (proc_if)
3821     {
3822       if (proc_if->generic)
3823         {
3824           gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
3825           return MATCH_ERROR;
3826         }
3827       if (proc_if->attr.proc == PROC_ST_FUNCTION)
3828         {
3829           gfc_error ("Interface '%s' at %C may not be a statement function",
3830                     proc_if->name);
3831           return MATCH_ERROR;
3832         }
3833       /* Handle intrinsic procedures.  */
3834       if (gfc_intrinsic_name (proc_if->name, 0)
3835           || gfc_intrinsic_name (proc_if->name, 1))
3836         proc_if->attr.intrinsic = 1;
3837       if (proc_if->attr.intrinsic
3838           && !gfc_intrinsic_actual_ok (proc_if->name, 0))
3839         {
3840           gfc_error ("Intrinsic procedure '%s' not allowed "
3841                     "in PROCEDURE statement at %C", proc_if->name);
3842           return MATCH_ERROR;
3843         }
3844       /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
3845          (proc_if->name, 0) after PR33162 is fixed.  */
3846       if (proc_if->attr.intrinsic)
3847         {
3848           gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
3849                      "in PROCEDURE statement at %C not yet implemented "
3850                      "in gfortran", proc_if->name);
3851           return MATCH_ERROR;
3852         }
3853     }
3854
3855 got_ts:
3856
3857   if (gfc_match (" )") != MATCH_YES)
3858     {
3859       gfc_current_locus = entry_loc;
3860       return MATCH_NO;
3861     }
3862
3863   /* Parse attributes.  */
3864   m = match_attr_spec();
3865   if (m == MATCH_ERROR)
3866     return MATCH_ERROR;
3867
3868   /* Get procedure symbols.  */
3869   for(num=1;;num++)
3870     {
3871
3872       m = gfc_match_symbol (&sym, 0);
3873       if (m == MATCH_NO)
3874         goto syntax;
3875       else if (m == MATCH_ERROR)
3876         return m;
3877
3878       /* Add current_attr to the symbol attributes.  */
3879       if (gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3880         return MATCH_ERROR;
3881
3882       if (sym->attr.is_bind_c)
3883         {
3884           /* Check for C1218.  */
3885           if (!proc_if || !proc_if->attr.is_bind_c)
3886             {
3887               gfc_error ("BIND(C) attribute at %C requires "
3888                         "an interface with BIND(C)");
3889               return MATCH_ERROR;
3890             }
3891           /* Check for C1217.  */
3892           if (has_name_equals && sym->attr.pointer)
3893             {
3894               gfc_error ("BIND(C) procedure with NAME may not have "
3895                         "POINTER attribute at %C");
3896               return MATCH_ERROR;
3897             }
3898           if (has_name_equals && sym->attr.dummy)
3899             {
3900               gfc_error ("Dummy procedure at %C may not have "
3901                         "BIND(C) attribute with NAME");
3902               return MATCH_ERROR;
3903             }
3904           /* Set binding label for BIND(C).  */
3905           if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
3906             return MATCH_ERROR;
3907         }
3908
3909       if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
3910         return MATCH_ERROR;
3911       if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
3912         return MATCH_ERROR;
3913
3914       /* Set interface.  */
3915       if (proc_if != NULL)
3916         sym->interface = proc_if;
3917       else if (current_ts.type != BT_UNKNOWN)
3918         {
3919           sym->interface = gfc_new_symbol ("", gfc_current_ns);
3920           sym->interface->ts = current_ts;
3921           sym->interface->attr.function = 1;
3922           sym->ts = sym->interface->ts;
3923           sym->attr.function = sym->interface->attr.function;
3924         }
3925
3926       if (gfc_match_eos () == MATCH_YES)
3927         return MATCH_YES;
3928       if (gfc_match_char (',') != MATCH_YES)
3929         goto syntax;
3930     }
3931
3932 syntax:
3933   gfc_error ("Syntax error in PROCEDURE statement at %C");
3934   return MATCH_ERROR;
3935 }
3936
3937
3938 /* Match a PROCEDURE declaration inside an interface (R1206).  */
3939
3940 static match
3941 match_procedure_in_interface (void)
3942 {
3943   match m;
3944   gfc_symbol *sym;
3945   char name[GFC_MAX_SYMBOL_LEN + 1];
3946
3947   if (current_interface.type == INTERFACE_NAMELESS
3948       || current_interface.type == INTERFACE_ABSTRACT)
3949     {
3950       gfc_error ("PROCEDURE at %C must be in a generic interface");
3951       return MATCH_ERROR;
3952     }
3953
3954   for(;;)
3955     {
3956       m = gfc_match_name (name);
3957       if (m == MATCH_NO)
3958         goto syntax;
3959       else if (m == MATCH_ERROR)
3960         return m;
3961       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3962         return MATCH_ERROR;
3963
3964       if (gfc_add_interface (sym) == FAILURE)
3965         return MATCH_ERROR;
3966
3967       sym->attr.procedure = 1;
3968
3969       if (gfc_match_eos () == MATCH_YES)
3970         break;
3971       if (gfc_match_char (',') != MATCH_YES)
3972         goto syntax;
3973     }
3974
3975   return MATCH_YES;
3976
3977 syntax:
3978   gfc_error ("Syntax error in PROCEDURE statement at %C");
3979   return MATCH_ERROR;
3980 }
3981
3982
3983 /* General matcher for PROCEDURE declarations.  */
3984
3985 match
3986 gfc_match_procedure (void)
3987 {
3988   match m;
3989
3990   switch (gfc_current_state ())
3991     {
3992     case COMP_NONE:
3993     case COMP_PROGRAM:
3994     case COMP_MODULE:
3995     case COMP_SUBROUTINE:
3996     case COMP_FUNCTION:
3997       m = match_procedure_decl ();
3998       break;
3999     case COMP_INTERFACE:
4000       m = match_procedure_in_interface ();
4001       break;
4002     case COMP_DERIVED:
4003       gfc_error ("Fortran 2003: Procedure components at %C are "
4004                 "not yet implemented in gfortran");
4005       return MATCH_ERROR;
4006     default:
4007       return MATCH_NO;
4008     }
4009
4010   if (m != MATCH_YES)
4011     return m;
4012
4013   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
4014       == FAILURE)
4015     return MATCH_ERROR;
4016
4017   return m;
4018 }
4019
4020
4021 /* Match a function declaration.  */
4022
4023 match
4024 gfc_match_function_decl (void)
4025 {
4026   char name[GFC_MAX_SYMBOL_LEN + 1];
4027   gfc_symbol *sym, *result;
4028   locus old_loc;
4029   match m;
4030   match suffix_match;
4031   match found_match; /* Status returned by match func.  */
4032
4033   if (gfc_current_state () != COMP_NONE
4034       && gfc_current_state () != COMP_INTERFACE
4035       && gfc_current_state () != COMP_CONTAINS)
4036     return MATCH_NO;
4037
4038   gfc_clear_ts (&current_ts);
4039
4040   old_loc = gfc_current_locus;
4041
4042   m = match_prefix (&current_ts);
4043   if (m != MATCH_YES)
4044     {
4045       gfc_current_locus = old_loc;
4046       return m;
4047     }
4048
4049   if (gfc_match ("function% %n", name) != MATCH_YES)
4050     {
4051       gfc_current_locus = old_loc;
4052       return MATCH_NO;
4053     }
4054   if (get_proc_name (name, &sym, false))
4055     return MATCH_ERROR;
4056   gfc_new_block = sym;
4057
4058   m = gfc_match_formal_arglist (sym, 0, 0);
4059   if (m == MATCH_NO)
4060     {
4061       gfc_error ("Expected formal argument list in function "
4062                  "definition at %C");
4063       m = MATCH_ERROR;
4064       goto cleanup;
4065     }
4066   else if (m == MATCH_ERROR)
4067     goto cleanup;
4068
4069   result = NULL;
4070
4071   /* According to the draft, the bind(c) and result clause can
4072      come in either order after the formal_arg_list (i.e., either
4073      can be first, both can exist together or by themselves or neither
4074      one).  Therefore, the match_result can't match the end of the
4075      string, and check for the bind(c) or result clause in either order.  */
4076   found_match = gfc_match_eos ();
4077
4078   /* Make sure that it isn't already declared as BIND(C).  If it is, it
4079      must have been marked BIND(C) with a BIND(C) attribute and that is
4080      not allowed for procedures.  */
4081   if (sym->attr.is_bind_c == 1)
4082     {
4083       sym->attr.is_bind_c = 0;
4084       if (sym->old_symbol != NULL)
4085         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4086                        "variables or common blocks",
4087                        &(sym->old_symbol->declared_at));
4088       else
4089         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4090                        "variables or common blocks", &gfc_current_locus);
4091     }
4092
4093   if (found_match != MATCH_YES)
4094     {
4095       /* If we haven't found the end-of-statement, look for a suffix.  */
4096       suffix_match = gfc_match_suffix (sym, &result);
4097       if (suffix_match == MATCH_YES)
4098         /* Need to get the eos now.  */
4099         found_match = gfc_match_eos ();
4100       else
4101         found_match = suffix_match;
4102     }
4103
4104   if(found_match != MATCH_YES)
4105     m = MATCH_ERROR;
4106   else
4107     {
4108       /* Make changes to the symbol.  */
4109       m = MATCH_ERROR;
4110
4111       if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
4112         goto cleanup;
4113
4114       if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
4115           || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4116         goto cleanup;
4117
4118       if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
4119           && !sym->attr.implicit_type)
4120         {
4121           gfc_error ("Function '%s' at %C already has a type of %s", name,
4122                      gfc_basic_typename (sym->ts.type));
4123           goto cleanup;
4124         }
4125
4126       if (result == NULL)
4127         {
4128           sym->ts = current_ts;
4129           sym->result = sym;
4130         }
4131       else
4132         {
4133           result->ts = current_ts;
4134           sym->result = result;
4135         }
4136
4137       return MATCH_YES;
4138     }
4139
4140 cleanup:
4141   gfc_current_locus = old_loc;
4142   return m;
4143 }
4144
4145
4146 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
4147    pass the name of the entry, rather than the gfc_current_block name, and
4148    to return false upon finding an existing global entry.  */
4149
4150 static bool
4151 add_global_entry (const char *name, int sub)
4152 {
4153   gfc_gsymbol *s;
4154
4155   s = gfc_get_gsymbol(name);
4156
4157   if (s->defined
4158       || (s->type != GSYM_UNKNOWN
4159           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4160     global_used(s, NULL);
4161   else
4162     {
4163       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4164       s->where = gfc_current_locus;
4165       s->defined = 1;
4166       return true;
4167     }
4168   return false;
4169 }
4170
4171
4172 /* Match an ENTRY statement.  */
4173
4174 match
4175 gfc_match_entry (void)
4176 {
4177   gfc_symbol *proc;
4178   gfc_symbol *result;
4179   gfc_symbol *entry;
4180   char name[GFC_MAX_SYMBOL_LEN + 1];
4181   gfc_compile_state state;
4182   match m;
4183   gfc_entry_list *el;
4184   locus old_loc;
4185   bool module_procedure;
4186
4187   m = gfc_match_name (name);
4188   if (m != MATCH_YES)
4189     return m;
4190
4191   state = gfc_current_state ();
4192   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
4193     {
4194       switch (state)
4195         {
4196           case COMP_PROGRAM:
4197             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
4198             break;
4199           case COMP_MODULE:
4200             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
4201             break;
4202           case COMP_BLOCK_DATA:
4203             gfc_error ("ENTRY statement at %C cannot appear within "
4204                        "a BLOCK DATA");
4205             break;
4206           case COMP_INTERFACE:
4207             gfc_error ("ENTRY statement at %C cannot appear within "
4208                        "an INTERFACE");
4209             break;
4210           case COMP_DERIVED:
4211             gfc_error ("ENTRY statement at %C cannot appear within "
4212                        "a DERIVED TYPE block");
4213             break;
4214           case COMP_IF:
4215             gfc_error ("ENTRY statement at %C cannot appear within "
4216                        "an IF-THEN block");
4217             break;
4218           case COMP_DO:
4219             gfc_error ("ENTRY statement at %C cannot appear within "
4220                        "a DO block");
4221             break;
4222           case COMP_SELECT:
4223             gfc_error ("ENTRY statement at %C cannot appear within "
4224                        "a SELECT block");
4225             break;
4226           case COMP_FORALL:
4227             gfc_error ("ENTRY statement at %C cannot appear within "
4228                        "a FORALL block");
4229             break;
4230           case COMP_WHERE:
4231             gfc_error ("ENTRY statement at %C cannot appear within "
4232                        "a WHERE block");
4233             break;
4234           case COMP_CONTAINS:
4235             gfc_error ("ENTRY statement at %C cannot appear within "
4236                        "a contained subprogram");
4237             break;
4238           default:
4239             gfc_internal_error ("gfc_match_entry(): Bad state");
4240         }
4241       return MATCH_ERROR;
4242     }
4243
4244   module_procedure = gfc_current_ns->parent != NULL
4245                    && gfc_current_ns->parent->proc_name
4246                    && gfc_current_ns->parent->proc_name->attr.flavor
4247                       == FL_MODULE;
4248
4249   if (gfc_current_ns->parent != NULL
4250       && gfc_current_ns->parent->proc_name
4251       && !module_procedure)
4252     {
4253       gfc_error("ENTRY statement at %C cannot appear in a "
4254                 "contained procedure");
4255       return MATCH_ERROR;
4256     }
4257
4258   /* Module function entries need special care in get_proc_name
4259      because previous references within the function will have
4260      created symbols attached to the current namespace.  */
4261   if (get_proc_name (name, &entry,
4262                      gfc_current_ns->parent != NULL
4263                      && module_procedure
4264                      && gfc_current_ns->proc_name->attr.function))
4265     return MATCH_ERROR;
4266
4267   proc = gfc_current_block ();
4268
4269   if (state == COMP_SUBROUTINE)
4270     {
4271       /* An entry in a subroutine.  */
4272       if (!add_global_entry (name, 1))
4273         return MATCH_ERROR;
4274
4275       m = gfc_match_formal_arglist (entry, 0, 1);
4276       if (m != MATCH_YES)
4277         return MATCH_ERROR;
4278
4279       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4280           || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4281         return MATCH_ERROR;
4282     }
4283   else
4284     {
4285       /* An entry in a function.
4286          We need to take special care because writing
4287             ENTRY f()
4288          as
4289             ENTRY f
4290          is allowed, whereas
4291             ENTRY f() RESULT (r)
4292          can't be written as
4293             ENTRY f RESULT (r).  */
4294       if (!add_global_entry (name, 0))
4295         return MATCH_ERROR;
4296
4297       old_loc = gfc_current_locus;
4298       if (gfc_match_eos () == MATCH_YES)
4299         {
4300           gfc_current_locus = old_loc;
4301           /* Match the empty argument list, and add the interface to
4302              the symbol.  */
4303           m = gfc_match_formal_arglist (entry, 0, 1);
4304         }
4305       else
4306         m = gfc_match_formal_arglist (entry, 0, 0);
4307
4308       if (m != MATCH_YES)
4309         return MATCH_ERROR;
4310
4311       result = NULL;
4312
4313       if (gfc_match_eos () == MATCH_YES)
4314         {
4315           if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4316               || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4317             return MATCH_ERROR;
4318
4319           entry->result = entry;
4320         }
4321       else
4322         {
4323           m = match_result (proc, &result);
4324           if (m == MATCH_NO)
4325             gfc_syntax_error (ST_ENTRY);
4326           if (m != MATCH_YES)
4327             return MATCH_ERROR;
4328
4329           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
4330               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
4331               || gfc_add_function (&entry->attr, result->name, NULL)
4332                  == FAILURE)
4333             return MATCH_ERROR;
4334
4335           entry->result = result;
4336         }
4337     }
4338
4339   if (gfc_match_eos () != MATCH_YES)
4340     {
4341       gfc_syntax_error (ST_ENTRY);
4342       return MATCH_ERROR;
4343     }
4344
4345   entry->attr.recursive = proc->attr.recursive;
4346   entry->attr.elemental = proc->attr.elemental;
4347   entry->attr.pure = proc->attr.pure;
4348
4349   el = gfc_get_entry_list ();
4350   el->sym = entry;
4351   el->next = gfc_current_ns->entries;
4352   gfc_current_ns->entries = el;
4353   if (el->next)
4354     el->id = el->next->id + 1;
4355   else
4356     el->id = 1;
4357
4358   new_st.op = EXEC_ENTRY;
4359   new_st.ext.entry = el;
4360
4361   return MATCH_YES;
4362 }
4363
4364
4365 /* Match a subroutine statement, including optional prefixes.  */
4366
4367 match
4368 gfc_match_subroutine (void)
4369 {
4370   char name[GFC_MAX_SYMBOL_LEN + 1];
4371   gfc_symbol *sym;
4372   match m;
4373   match is_bind_c;
4374   char peek_char;
4375
4376   if (gfc_current_state () != COMP_NONE
4377       && gfc_current_state () != COMP_INTERFACE
4378       && gfc_current_state () != COMP_CONTAINS)
4379     return MATCH_NO;
4380
4381   m = match_prefix (NULL);
4382   if (m != MATCH_YES)
4383     return m;
4384
4385   m = gfc_match ("subroutine% %n", name);
4386   if (m != MATCH_YES)
4387     return m;
4388
4389   if (get_proc_name (name, &sym, false))
4390     return MATCH_ERROR;
4391   gfc_new_block = sym;
4392
4393   /* Check what next non-whitespace character is so we can tell if there
4394      where the required parens if we have a BIND(C).  */
4395   gfc_gobble_whitespace ();
4396   peek_char = gfc_peek_char ();
4397
4398   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4399     return MATCH_ERROR;
4400
4401   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4402     return MATCH_ERROR;
4403
4404   /* Make sure that it isn't already declared as BIND(C).  If it is, it
4405      must have been marked BIND(C) with a BIND(C) attribute and that is
4406      not allowed for procedures.  */
4407   if (sym->attr.is_bind_c == 1)
4408     {
4409       sym->attr.is_bind_c = 0;
4410       if (sym->old_symbol != NULL)
4411         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4412                        "variables or common blocks",
4413                        &(sym->old_symbol->declared_at));
4414       else
4415         gfc_error_now ("BIND(C) attribute at %L can only be used for "
4416                        "variables or common blocks", &gfc_current_locus);
4417     }
4418
4419   /* Here, we are just checking if it has the bind(c) attribute, and if
4420      so, then we need to make sure it's all correct.  If it doesn't,
4421      we still need to continue matching the rest of the subroutine line.  */
4422   is_bind_c = gfc_match_bind_c (sym);
4423   if (is_bind_c == MATCH_ERROR)
4424     {
4425       /* There was an attempt at the bind(c), but it was wrong.  An
4426          error message should have been printed w/in the gfc_match_bind_c
4427          so here we'll just return the MATCH_ERROR.  */
4428       return MATCH_ERROR;
4429     }
4430
4431   if (is_bind_c == MATCH_YES)
4432     {
4433       if (peek_char != '(')
4434         {
4435           gfc_error ("Missing required parentheses before BIND(C) at %C");
4436           return MATCH_ERROR;
4437         }
4438       if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4439           == FAILURE)
4440         return MATCH_ERROR;
4441     }
4442
4443   if (gfc_match_eos () != MATCH_YES)
4444     {
4445       gfc_syntax_error (ST_SUBROUTINE);
4446       return MATCH_ERROR;
4447     }
4448
4449   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4450     return MATCH_ERROR;
4451
4452   return MATCH_YES;
4453 }
4454
4455
4456 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4457    given, and set the binding label in either the given symbol (if not
4458    NULL), or in the current_ts.  The symbol may be NULL because we may
4459    encounter the BIND(C) before the declaration itself.  Return
4460    MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4461    MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4462    or MATCH_YES if the specifier was correct and the binding label and
4463    bind(c) fields were set correctly for the given symbol or the
4464    current_ts.  */
4465
4466 match
4467 gfc_match_bind_c (gfc_symbol *sym)
4468 {
4469   /* binding label, if exists */
4470   char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4471   match double_quote;
4472   match single_quote;
4473
4474   /* Initialize the flag that specifies whether we encountered a NAME=
4475      specifier or not.  */
4476   has_name_equals = 0;
4477
4478   /* Init the first char to nil so we can catch if we don't have
4479      the label (name attr) or the symbol name yet.  */
4480   binding_label[0] = '\0';
4481
4482   /* This much we have to be able to match, in this order, if
4483      there is a bind(c) label.  */
4484   if (gfc_match (" bind ( c ") != MATCH_YES)
4485     return MATCH_NO;
4486
4487   /* Now see if there is a binding label, or if we've reached the
4488      end of the bind(c) attribute without one.  */
4489   if (gfc_match_char (',') == MATCH_YES)
4490     {
4491       if (gfc_match (" name = ") != MATCH_YES)
4492         {
4493           gfc_error ("Syntax error in NAME= specifier for binding label "
4494                      "at %C");
4495           /* should give an error message here */
4496           return MATCH_ERROR;
4497         }
4498
4499       has_name_equals = 1;
4500
4501       /* Get the opening quote.  */
4502       double_quote = MATCH_YES;
4503       single_quote = MATCH_YES;
4504       double_quote = gfc_match_char ('"');
4505       if (double_quote != MATCH_YES)
4506         single_quote = gfc_match_char ('\'');
4507       if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4508         {
4509           gfc_error ("Syntax error in NAME= specifier for binding label "
4510                      "at %C");
4511           return MATCH_ERROR;
4512         }
4513
4514       /* Grab the binding label, using functions that will not lower
4515          case the names automatically.  */
4516       if (gfc_match_name_C (binding_label) != MATCH_YES)
4517          return MATCH_ERROR;
4518
4519       /* Get the closing quotation.  */
4520       if (double_quote == MATCH_YES)
4521         {
4522           if (gfc_match_char ('"') != MATCH_YES)
4523             {
4524               gfc_error ("Missing closing quote '\"' for binding label at %C");
4525               /* User started string with '"' so looked to match it.  */
4526               return MATCH_ERROR;
4527             }
4528         }
4529       else
4530         {
4531           if (gfc_match_char ('\'') != MATCH_YES)
4532             {
4533               gfc_error ("Missing closing quote '\'' for binding label at %C");
4534               /* User started string with "'" char.  */
4535               return MATCH_ERROR;
4536             }
4537         }
4538    }
4539
4540   /* Get the required right paren.  */
4541   if (gfc_match_char (')') != MATCH_YES)
4542     {
4543       gfc_error ("Missing closing paren for binding label at %C");
4544       return MATCH_ERROR;
4545     }
4546
4547   /* Save the binding label to the symbol.  If sym is null, we're
4548      probably matching the typespec attributes of a declaration and
4549      haven't gotten the name yet, and therefore, no symbol yet.  */
4550   if (binding_label[0] != '\0')
4551     {
4552       if (sym != NULL)
4553       {
4554         strncpy (sym->binding_label, binding_label,
4555                  strlen (binding_label)+1);
4556       }
4557       else
4558         strncpy (curr_binding_label, binding_label,
4559                  strlen (binding_label) + 1);
4560     }
4561   else
4562     {
4563       /* No binding label, but if symbol isn't null, we
4564          can set the label for it here.  */
4565       /* TODO: If the name= was given and no binding label (name=""), we simply
4566          will let fortran mangle the symbol name as it usually would.
4567          However, this could still let C call it if the user looked up the
4568          symbol in the object file.  Should the name set during mangling in
4569          trans-decl.c be marked with characters that are invalid for C to
4570          prevent this?  */
4571       if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4572         strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4573     }
4574
4575   if (has_name_equals && gfc_current_state () == COMP_INTERFACE
4576       && current_interface.type == INTERFACE_ABSTRACT)
4577     {
4578       gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4579       return MATCH_ERROR;
4580     }
4581
4582   return MATCH_YES;
4583 }
4584
4585
4586 /* Return nonzero if we're currently compiling a contained procedure.  */
4587
4588 static int
4589 contained_procedure (void)
4590 {
4591   gfc_state_data *s;
4592
4593   for (s=gfc_state_stack; s; s=s->previous)
4594     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4595         && s->previous != NULL && s->previous->state == COMP_CONTAINS)
4596       return 1;
4597
4598   return 0;
4599 }
4600
4601 /* Set the kind of each enumerator.  The kind is selected such that it is
4602    interoperable with the corresponding C enumeration type, making
4603    sure that -fshort-enums is honored.  */
4604
4605 static void
4606 set_enum_kind(void)
4607 {
4608   enumerator_history *current_history = NULL;
4609   int kind;
4610   int i;
4611
4612   if (max_enum == NULL || enum_history == NULL)
4613     return;
4614
4615   if (!gfc_option.fshort_enums)
4616     return;
4617
4618   i = 0;
4619   do
4620     {
4621       kind = gfc_integer_kinds[i++].kind;
4622     }
4623   while (kind < gfc_c_int_kind
4624          && gfc_check_integer_range (max_enum->initializer->value.integer,
4625                                      kind) != ARITH_OK);
4626
4627   current_history = enum_history;
4628   while (current_history != NULL)
4629     {
4630       current_history->sym->ts.kind = kind;
4631       current_history = current_history->next;
4632     }
4633 }
4634
4635
4636 /* Match any of the various end-block statements.  Returns the type of
4637    END to the caller.  The END INTERFACE, END IF, END DO and END
4638    SELECT statements cannot be replaced by a single END statement.  */
4639
4640 match
4641 gfc_match_end (gfc_statement *st)
4642 {
4643   char name[GFC_MAX_SYMBOL_LEN + 1];
4644   gfc_compile_state state;
4645   locus old_loc;
4646   const char *block_name;
4647   const char *target;
4648   int eos_ok;
4649   match m;
4650
4651   old_loc = gfc_current_locus;
4652   if (gfc_match ("end") != MATCH_YES)
4653     return MATCH_NO;
4654
4655   state = gfc_current_state ();
4656   block_name = gfc_current_block () == NULL
4657              ? NULL : gfc_current_block ()->name;
4658
4659   if (state == COMP_CONTAINS)
4660     {
4661       state = gfc_state_stack->previous->state;
4662       block_name = gfc_state_stack->previous->sym == NULL
4663                  ? NULL : gfc_state_stack->previous->sym->name;
4664     }
4665
4666   switch (state)
4667     {
4668     case COMP_NONE:
4669     case COMP_PROGRAM:
4670       *st = ST_END_PROGRAM;
4671       target = " program";
4672       eos_ok = 1;
4673       break;
4674
4675     case COMP_SUBROUTINE:
4676       *st = ST_END_SUBROUTINE;
4677       target = " subroutine";
4678       eos_ok = !contained_procedure ();
4679       break;
4680
4681     case COMP_FUNCTION:
4682       *st = ST_END_FUNCTION;
4683       target = " function";
4684       eos_ok = !contained_procedure ();
4685       break;
4686
4687     case COMP_BLOCK_DATA:
4688       *st = ST_END_BLOCK_DATA;
4689       target = " block data";
4690       eos_ok = 1;
4691       break;
4692
4693     case COMP_MODULE:
4694       *st = ST_END_MODULE;
4695       target = " module";
4696       eos_ok = 1;
4697       break;
4698
4699     case COMP_INTERFACE:
4700       *st = ST_END_INTERFACE;
4701       target = " interface";
4702       eos_ok = 0;
4703       break;
4704
4705     case COMP_DERIVED:
4706       *st = ST_END_TYPE;
4707       target = " type";
4708       eos_ok = 0;
4709       break;
4710
4711     case COMP_IF:
4712       *st = ST_ENDIF;
4713       target = " if";
4714       eos_ok = 0;
4715       break;
4716
4717     case COMP_DO:
4718       *st = ST_ENDDO;
4719       target = " do";
4720       eos_ok = 0;
4721       break;
4722
4723     case COMP_SELECT:
4724       *st = ST_END_SELECT;
4725       target = " select";
4726       eos_ok = 0;
4727       break;
4728
4729     case COMP_FORALL:
4730       *st = ST_END_FORALL;
4731       target = " forall";
4732       eos_ok = 0;
4733       break;
4734
4735     case COMP_WHERE:
4736       *st = ST_END_WHERE;
4737       target = " where";
4738       eos_ok = 0;
4739       break;
4740
4741     case COMP_ENUM:
4742       *st = ST_END_ENUM;
4743       target = " enum";
4744       eos_ok = 0;
4745       last_initializer = NULL;
4746       set_enum_kind ();
4747       gfc_free_enum_history ();
4748       break;
4749
4750     default:
4751       gfc_error ("Unexpected END statement at %C");
4752       goto cleanup;
4753     }
4754
4755   if (gfc_match_eos () == MATCH_YES)
4756     {
4757       if (!eos_ok)
4758         {
4759           /* We would have required END [something].  */
4760           gfc_error ("%s statement expected at %L",
4761                      gfc_ascii_statement (*st), &old_loc);
4762           goto cleanup;
4763         }
4764
4765       return MATCH_YES;
4766     }
4767
4768   /* Verify that we've got the sort of end-block that we're expecting.  */
4769   if (gfc_match (target) != MATCH_YES)
4770     {
4771       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
4772       goto cleanup;
4773     }
4774
4775   /* If we're at the end, make sure a block name wasn't required.  */
4776   if (gfc_match_eos () == MATCH_YES)
4777     {
4778
4779       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
4780           && *st != ST_END_FORALL && *st != ST_END_WHERE)
4781         return MATCH_YES;
4782
4783       if (gfc_current_block () == NULL)
4784         return MATCH_YES;
4785
4786       gfc_error ("Expected block name of '%s' in %s statement at %C",
4787                  block_name, gfc_ascii_statement (*st));
4788
4789       return MATCH_ERROR;
4790     }
4791
4792   /* END INTERFACE has a special handler for its several possible endings.  */
4793   if (*st == ST_END_INTERFACE)
4794     return gfc_match_end_interface ();
4795
4796   /* We haven't hit the end of statement, so what is left must be an
4797      end-name.  */
4798   m = gfc_match_space ();
4799   if (m == MATCH_YES)
4800     m = gfc_match_name (name);
4801
4802   if (m == MATCH_NO)
4803     gfc_error ("Expected terminating name at %C");
4804   if (m != MATCH_YES)
4805     goto cleanup;
4806
4807   if (block_name == NULL)
4808     goto syntax;
4809
4810   if (strcmp (name, block_name) != 0)
4811     {
4812       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
4813                  gfc_ascii_statement (*st));
4814       goto cleanup;
4815     }
4816
4817   if (gfc_match_eos () == MATCH_YES)
4818     return MATCH_YES;
4819
4820 syntax:
4821   gfc_syntax_error (*st);
4822
4823 cleanup:
4824   gfc_current_locus = old_loc;
4825   return MATCH_ERROR;
4826 }
4827
4828
4829
4830 /***************** Attribute declaration statements ****************/
4831
4832 /* Set the attribute of a single variable.  */
4833
4834 static match
4835 attr_decl1 (void)
4836 {
4837   char name[GFC_MAX_SYMBOL_LEN + 1];
4838   gfc_array_spec *as;
4839   gfc_symbol *sym;
4840   locus var_locus;
4841   match m;
4842
4843   as = NULL;
4844
4845   m = gfc_match_name (name);
4846   if (m != MATCH_YES)
4847     goto cleanup;
4848
4849   if (find_special (name, &sym))
4850     return MATCH_ERROR;
4851
4852   var_locus = gfc_current_locus;
4853
4854   /* Deal with possible array specification for certain attributes.  */
4855   if (current_attr.dimension
4856       || current_attr.allocatable
4857       || current_attr.pointer
4858       || current_attr.target)
4859     {
4860       m = gfc_match_array_spec (&as);
4861       if (m == MATCH_ERROR)
4862         goto cleanup;
4863
4864       if (current_attr.dimension && m == MATCH_NO)
4865         {
4866           gfc_error ("Missing array specification at %L in DIMENSION "
4867                      "statement", &var_locus);
4868           m = MATCH_ERROR;
4869           goto cleanup;
4870         }
4871
4872       if ((current_attr.allocatable || current_attr.pointer)
4873           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
4874         {
4875           gfc_error ("Array specification must be deferred at %L", &var_locus);
4876           m = MATCH_ERROR;
4877           goto cleanup;
4878         }
4879     }
4880
4881   /* Update symbol table.  DIMENSION attribute is set
4882      in gfc_set_array_spec().  */
4883   if (current_attr.dimension == 0
4884       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
4885     {
4886       m = MATCH_ERROR;
4887       goto cleanup;
4888     }
4889
4890   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
4891     {
4892       m = MATCH_ERROR;
4893       goto cleanup;
4894     }
4895
4896   if (sym->attr.cray_pointee && sym->as != NULL)
4897     {
4898       /* Fix the array spec.  */
4899       m = gfc_mod_pointee_as (sym->as);
4900       if (m == MATCH_ERROR)
4901         goto cleanup;
4902     }
4903
4904   if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
4905     {
4906       m = MATCH_ERROR;
4907       goto cleanup;
4908     }
4909
4910   if ((current_attr.external || current_attr.intrinsic)
4911       && sym->attr.flavor != FL_PROCEDURE
4912       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
4913     {
4914       m = MATCH_ERROR;
4915       goto cleanup;
4916     }
4917
4918   return MATCH_YES;
4919
4920 cleanup:
4921   gfc_free_array_spec (as);
4922   return m;
4923 }
4924
4925
4926 /* Generic attribute declaration subroutine.  Used for attributes that
4927    just have a list of names.  */
4928
4929 static match
4930 attr_decl (void)
4931 {
4932   match m;
4933
4934   /* Gobble the optional double colon, by simply ignoring the result
4935      of gfc_match().  */
4936   gfc_match (" ::");
4937
4938   for (;;)
4939     {
4940       m = attr_decl1 ();
4941       if (m != MATCH_YES)
4942         break;
4943
4944       if (gfc_match_eos () == MATCH_YES)
4945         {
4946           m = MATCH_YES;
4947           break;
4948         }
4949
4950       if (gfc_match_char (',') != MATCH_YES)
4951         {
4952           gfc_error ("Unexpected character in variable list at %C");
4953           m = MATCH_ERROR;
4954           break;
4955         }
4956     }
4957
4958   return m;
4959 }
4960
4961
4962 /* This routine matches Cray Pointer declarations of the form:
4963    pointer ( <pointer>, <pointee> )
4964    or
4965    pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
4966    The pointer, if already declared, should be an integer.  Otherwise, we
4967    set it as BT_INTEGER with kind gfc_index_integer_kind.  The pointee may
4968    be either a scalar, or an array declaration.  No space is allocated for
4969    the pointee.  For the statement
4970    pointer (ipt, ar(10))
4971    any subsequent uses of ar will be translated (in C-notation) as
4972    ar(i) => ((<type> *) ipt)(i)
4973    After gimplification, pointee variable will disappear in the code.  */
4974
4975 static match
4976 cray_pointer_decl (void)
4977 {
4978   match m;
4979   gfc_array_spec *as;
4980   gfc_symbol *cptr; /* Pointer symbol.  */
4981   gfc_symbol *cpte; /* Pointee symbol.  */
4982   locus var_locus;
4983   bool done = false;
4984
4985   while (!done)
4986     {
4987       if (gfc_match_char ('(') != MATCH_YES)
4988         {
4989           gfc_error ("Expected '(' at %C");
4990           return MATCH_ERROR;
4991         }
4992
4993       /* Match pointer.  */
4994       var_locus = gfc_current_locus;
4995       gfc_clear_attr (&current_attr);
4996       gfc_add_cray_pointer (&current_attr, &var_locus);
4997       current_ts.type = BT_INTEGER;
4998       current_ts.kind = gfc_index_integer_kind;
4999
5000       m = gfc_match_symbol (&cptr, 0);
5001       if (m != MATCH_YES)
5002         {
5003           gfc_error ("Expected variable name at %C");
5004           return m;
5005         }
5006
5007       if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
5008         return MATCH_ERROR;
5009
5010       gfc_set_sym_referenced (cptr);
5011
5012       if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
5013         {
5014           cptr->ts.type = BT_INTEGER;
5015           cptr->ts.kind = gfc_index_integer_kind;
5016         }
5017       else if (cptr->ts.type != BT_INTEGER)
5018         {
5019           gfc_error ("Cray pointer at %C must be an integer");
5020           return MATCH_ERROR;
5021         }
5022       else if (cptr->ts.kind < gfc_index_integer_kind)
5023         gfc_warning ("Cray pointer at %C has %d bytes of precision;"
5024                      " memory addresses require %d bytes",
5025                      cptr->ts.kind, gfc_index_integer_kind);
5026
5027       if (gfc_match_char (',') != MATCH_YES)
5028         {
5029           gfc_error ("Expected \",\" at %C");
5030           return MATCH_ERROR;
5031         }
5032
5033       /* Match Pointee.  */
5034       var_locus = gfc_current_locus;
5035       gfc_clear_attr (&current_attr);
5036       gfc_add_cray_pointee (&current_attr, &var_locus);
5037       current_ts.type = BT_UNKNOWN;
5038       current_ts.kind = 0;
5039
5040       m = gfc_match_symbol (&cpte, 0);
5041       if (m != MATCH_YES)
5042         {
5043           gfc_error ("Expected variable name at %C");
5044           return m;
5045         }
5046
5047       /* Check for an optional array spec.  */
5048       m = gfc_match_array_spec (&as);
5049       if (m == MATCH_ERROR)
5050         {
5051           gfc_free_array_spec (as);
5052           return m;
5053         }
5054       else if (m == MATCH_NO)
5055         {
5056           gfc_free_array_spec (as);
5057           as = NULL;
5058         }
5059
5060       if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
5061         return MATCH_ERROR;
5062
5063       gfc_set_sym_referenced (cpte);
5064
5065       if (cpte->as == NULL)
5066         {
5067           if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
5068             gfc_internal_error ("Couldn't set Cray pointee array spec.");
5069         }
5070       else if (as != NULL)
5071         {
5072           gfc_error ("Duplicate array spec for Cray pointee at %C");
5073           gfc_free_array_spec (as);
5074           return MATCH_ERROR;
5075         }
5076
5077       as = NULL;
5078
5079       if (cpte->as != NULL)
5080         {
5081           /* Fix array spec.  */
5082           m = gfc_mod_pointee_as (cpte->as);
5083           if (m == MATCH_ERROR)
5084             return m;
5085         }
5086
5087       /* Point the Pointee at the Pointer.  */
5088       cpte->cp_pointer = cptr;
5089
5090       if (gfc_match_char (')') != MATCH_YES)
5091         {
5092           gfc_error ("Expected \")\" at %C");
5093           return MATCH_ERROR;
5094         }
5095       m = gfc_match_char (',');
5096       if (m != MATCH_YES)
5097         done = true; /* Stop searching for more declarations.  */
5098
5099     }
5100
5101   if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
5102       || gfc_match_eos () != MATCH_YES)
5103     {
5104       gfc_error ("Expected \",\" or end of statement at %C");
5105       return MATCH_ERROR;
5106     }
5107   return MATCH_YES;
5108 }
5109
5110
5111 match
5112 gfc_match_external (void)
5113 {
5114
5115   gfc_clear_attr (&current_attr);
5116   current_attr.external = 1;
5117
5118   return attr_decl ();
5119 }
5120
5121
5122 match
5123 gfc_match_intent (void)
5124 {
5125   sym_intent intent;
5126
5127   intent = match_intent_spec ();
5128   if (intent == INTENT_UNKNOWN)
5129     return MATCH_ERROR;
5130
5131   gfc_clear_attr (&current_attr);
5132   current_attr.intent = intent;
5133
5134   return attr_decl ();
5135 }
5136
5137
5138 match
5139 gfc_match_intrinsic (void)
5140 {
5141
5142   gfc_clear_attr (&current_attr);
5143   current_attr.intrinsic = 1;
5144
5145   return attr_decl ();
5146 }
5147
5148
5149 match
5150 gfc_match_optional (void)
5151 {
5152
5153   gfc_clear_attr (&current_attr);
5154   current_attr.optional = 1;
5155
5156   return attr_decl ();
5157 }
5158
5159
5160 match
5161 gfc_match_pointer (void)
5162 {
5163   gfc_gobble_whitespace ();
5164   if (gfc_peek_char () == '(')
5165     {
5166       if (!gfc_option.flag_cray_pointer)
5167         {
5168           gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
5169                      "flag");
5170           return MATCH_ERROR;
5171         }
5172       return cray_pointer_decl ();
5173     }
5174   else
5175     {
5176       gfc_clear_attr (&current_attr);
5177       current_attr.pointer = 1;
5178
5179       return attr_decl ();
5180     }
5181 }
5182
5183
5184 match
5185 gfc_match_allocatable (void)
5186 {
5187   gfc_clear_attr (&current_attr);
5188   current_attr.allocatable = 1;
5189
5190   return attr_decl ();
5191 }
5192
5193
5194 match
5195 gfc_match_dimension (void)
5196 {
5197   gfc_clear_attr (&current_attr);
5198   current_attr.dimension = 1;
5199
5200   return attr_decl ();
5201 }
5202
5203
5204 match
5205 gfc_match_target (void)
5206 {
5207   gfc_clear_attr (&current_attr);
5208   current_attr.target = 1;
5209
5210   return attr_decl ();
5211 }
5212
5213
5214 /* Match the list of entities being specified in a PUBLIC or PRIVATE
5215    statement.  */
5216
5217 static match
5218 access_attr_decl (gfc_statement st)
5219 {
5220   char name[GFC_MAX_SYMBOL_LEN + 1];
5221   interface_type type;
5222   gfc_user_op *uop;
5223   gfc_symbol *sym;
5224   gfc_intrinsic_op operator;
5225   match m;
5226
5227   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5228     goto done;
5229
5230   for (;;)
5231     {
5232       m = gfc_match_generic_spec (&type, name, &operator);
5233       if (m == MATCH_NO)
5234         goto syntax;
5235       if (m == MATCH_ERROR)
5236         return MATCH_ERROR;
5237
5238       switch (type)
5239         {
5240         case INTERFACE_NAMELESS:
5241         case INTERFACE_ABSTRACT:
5242           goto syntax;
5243
5244         case INTERFACE_GENERIC:
5245           if (gfc_get_symbol (name, NULL, &sym))
5246             goto done;
5247
5248           if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
5249                                           ? ACCESS_PUBLIC : ACCESS_PRIVATE,
5250                               sym->name, NULL) == FAILURE)
5251             return MATCH_ERROR;
5252
5253           break;
5254
5255         case INTERFACE_INTRINSIC_OP:
5256           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
5257             {
5258               gfc_current_ns->operator_access[operator] =
5259                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5260             }
5261           else
5262             {
5263               gfc_error ("Access specification of the %s operator at %C has "
5264                          "already been specified", gfc_op2string (operator));
5265               goto done;
5266             }
5267
5268           break;
5269
5270         case INTERFACE_USER_OP:
5271           uop = gfc_get_uop (name);
5272
5273           if (uop->access == ACCESS_UNKNOWN)
5274             {
5275               uop->access = (st == ST_PUBLIC)
5276                           ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5277             }
5278           else
5279             {
5280               gfc_error ("Access specification of the .%s. operator at %C "
5281                          "has already been specified", sym->name);
5282               goto done;
5283             }
5284
5285           break;
5286         }
5287
5288       if (gfc_match_char (',') == MATCH_NO)
5289         break;
5290     }
5291
5292   if (gfc_match_eos () != MATCH_YES)
5293     goto syntax;
5294   return MATCH_YES;
5295
5296 syntax:
5297   gfc_syntax_error (st);
5298
5299 done:
5300   return MATCH_ERROR;
5301 }
5302
5303
5304 match
5305 gfc_match_protected (void)
5306 {
5307   gfc_symbol *sym;
5308   match m;
5309
5310   if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5311     {
5312        gfc_error ("PROTECTED at %C only allowed in specification "
5313                   "part of a module");
5314        return MATCH_ERROR;
5315
5316     }
5317
5318   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
5319       == FAILURE)
5320     return MATCH_ERROR;
5321
5322   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5323     {
5324       return MATCH_ERROR;
5325     }
5326
5327   if (gfc_match_eos () == MATCH_YES)
5328     goto syntax;
5329
5330   for(;;)
5331     {
5332       m = gfc_match_symbol (&sym, 0);
5333       switch (m)
5334         {
5335         case MATCH_YES:
5336           if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
5337               == FAILURE)
5338             return MATCH_ERROR;
5339           goto next_item;
5340
5341         case MATCH_NO:
5342           break;
5343
5344         case MATCH_ERROR:
5345           return MATCH_ERROR;
5346         }
5347
5348     next_item:
5349       if (gfc_match_eos () == MATCH_YES)
5350         break;
5351       if (gfc_match_char (',') != MATCH_YES)
5352         goto syntax;
5353     }
5354
5355   return MATCH_YES;
5356
5357 syntax:
5358   gfc_error ("Syntax error in PROTECTED statement at %C");
5359   return MATCH_ERROR;
5360 }
5361
5362
5363 /* The PRIVATE statement is a bit weird in that it can be an attribute
5364    declaration, but also works as a standlone statement inside of a
5365    type declaration or a module.  */
5366
5367 match
5368 gfc_match_private (gfc_statement *st)
5369 {
5370
5371   if (gfc_match ("private") != MATCH_YES)
5372     return MATCH_NO;
5373
5374   if (gfc_current_state () != COMP_MODULE
5375       && (gfc_current_state () != COMP_DERIVED
5376           || !gfc_state_stack->previous
5377           || gfc_state_stack->previous->state != COMP_MODULE))
5378     {
5379       gfc_error ("PRIVATE statement at %C is only allowed in the "
5380                  "specification part of a module");
5381       return MATCH_ERROR;
5382     }
5383
5384   if (gfc_current_state () == COMP_DERIVED)
5385     {
5386       if (gfc_match_eos () == MATCH_YES)
5387         {
5388           *st = ST_PRIVATE;
5389           return MATCH_YES;
5390         }
5391
5392       gfc_syntax_error (ST_PRIVATE);
5393       return MATCH_ERROR;
5394     }
5395
5396   if (gfc_match_eos () == MATCH_YES)
5397     {
5398       *st = ST_PRIVATE;
5399       return MATCH_YES;
5400     }
5401
5402   *st = ST_ATTR_DECL;
5403   return access_attr_decl (ST_PRIVATE);
5404 }
5405
5406
5407 match
5408 gfc_match_public (gfc_statement *st)
5409 {
5410
5411   if (gfc_match ("public") != MATCH_YES)
5412     return MATCH_NO;
5413
5414   if (gfc_current_state () != COMP_MODULE)
5415     {
5416       gfc_error ("PUBLIC statement at %C is only allowed in the "
5417                  "specification part of a module");
5418       return MATCH_ERROR;
5419     }
5420
5421   if (gfc_match_eos () == MATCH_YES)
5422     {
5423       *st = ST_PUBLIC;
5424       return MATCH_YES;
5425     }
5426
5427   *st = ST_ATTR_DECL;
5428   return access_attr_decl (ST_PUBLIC);
5429 }
5430
5431
5432 /* Workhorse for gfc_match_parameter.  */
5433
5434 static match
5435 do_parm (void)
5436 {
5437   gfc_symbol *sym;
5438   gfc_expr *init;
5439   match m;
5440
5441   m = gfc_match_symbol (&sym, 0);
5442   if (m == MATCH_NO)
5443     gfc_error ("Expected variable name at %C in PARAMETER statement");
5444
5445   if (m != MATCH_YES)
5446     return m;
5447
5448   if (gfc_match_char ('=') == MATCH_NO)
5449     {
5450       gfc_error ("Expected = sign in PARAMETER statement at %C");
5451       return MATCH_ERROR;
5452     }
5453
5454   m = gfc_match_init_expr (&init);
5455   if (m == MATCH_NO)
5456     gfc_error ("Expected expression at %C in PARAMETER statement");
5457   if (m != MATCH_YES)
5458     return m;
5459
5460   if (sym->ts.type == BT_UNKNOWN
5461       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5462     {
5463       m = MATCH_ERROR;
5464       goto cleanup;
5465     }
5466
5467   if (gfc_check_assign_symbol (sym, init) == FAILURE
5468       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
5469     {
5470       m = MATCH_ERROR;
5471       goto cleanup;
5472     }
5473
5474   if (sym->ts.type == BT_CHARACTER
5475       && sym->ts.cl != NULL
5476       && sym->ts.cl->length != NULL
5477       && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5478       && init->expr_type == EXPR_CONSTANT
5479       && init->ts.type == BT_CHARACTER
5480       && init->ts.kind == 1)
5481     gfc_set_constant_character_len (
5482       mpz_get_si (sym->ts.cl->length->value.integer), init, false);
5483
5484   sym->value = init;
5485   return MATCH_YES;
5486
5487 cleanup:
5488   gfc_free_expr (init);
5489   return m;
5490 }
5491
5492
5493 /* Match a parameter statement, with the weird syntax that these have.  */
5494
5495 match
5496 gfc_match_parameter (void)
5497 {
5498   match m;
5499
5500   if (gfc_match_char ('(') == MATCH_NO)
5501     return MATCH_NO;
5502
5503   for (;;)
5504     {
5505       m = do_parm ();
5506       if (m != MATCH_YES)
5507         break;
5508
5509       if (gfc_match (" )%t") == MATCH_YES)
5510         break;
5511
5512       if (gfc_match_char (',') != MATCH_YES)
5513         {
5514           gfc_error ("Unexpected characters in PARAMETER statement at %C");
5515           m = MATCH_ERROR;
5516           break;
5517         }
5518     }
5519
5520   return m;
5521 }
5522
5523
5524 /* Save statements have a special syntax.  */
5525
5526 match
5527 gfc_match_save (void)
5528 {
5529   char n[GFC_MAX_SYMBOL_LEN+1];
5530   gfc_common_head *c;
5531   gfc_symbol *sym;
5532   match m;
5533
5534   if (gfc_match_eos () == MATCH_YES)
5535     {
5536       if (gfc_current_ns->seen_save)
5537         {
5538           if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5539                               "follows previous SAVE statement")
5540               == FAILURE)
5541             return MATCH_ERROR;
5542         }
5543
5544       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5545       return MATCH_YES;
5546     }
5547
5548   if (gfc_current_ns->save_all)
5549     {
5550       if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5551                           "blanket SAVE statement")
5552           == FAILURE)
5553         return MATCH_ERROR;
5554     }
5555
5556   gfc_match (" ::");
5557
5558   for (;;)
5559     {
5560       m = gfc_match_symbol (&sym, 0);
5561       switch (m)
5562         {
5563         case MATCH_YES:
5564           if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
5565               == FAILURE)
5566             return MATCH_ERROR;
5567           goto next_item;
5568
5569         case MATCH_NO:
5570           break;
5571
5572         case MATCH_ERROR:
5573           return MATCH_ERROR;
5574         }
5575
5576       m = gfc_match (" / %n /", &n);
5577       if (m == MATCH_ERROR)
5578         return MATCH_ERROR;
5579       if (m == MATCH_NO)
5580         goto syntax;
5581
5582       c = gfc_get_common (n, 0);
5583       c->saved = 1;
5584
5585       gfc_current_ns->seen_save = 1;
5586
5587     next_item:
5588       if (gfc_match_eos () == MATCH_YES)
5589         break;
5590       if (gfc_match_char (',') != MATCH_YES)
5591         goto syntax;
5592     }
5593
5594   return MATCH_YES;
5595
5596 syntax:
5597   gfc_error ("Syntax error in SAVE statement at %C");
5598   return MATCH_ERROR;
5599 }
5600
5601
5602 match
5603 gfc_match_value (void)
5604 {
5605   gfc_symbol *sym;
5606   match m;
5607
5608   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
5609       == FAILURE)
5610     return MATCH_ERROR;
5611
5612   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5613     {
5614       return MATCH_ERROR;
5615     }
5616
5617   if (gfc_match_eos () == MATCH_YES)
5618     goto syntax;
5619
5620   for(;;)
5621     {
5622       m = gfc_match_symbol (&sym, 0);
5623       switch (m)
5624         {
5625         case MATCH_YES:
5626           if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
5627               == FAILURE)
5628             return MATCH_ERROR;
5629           goto next_item;
5630
5631         case MATCH_NO:
5632           break;
5633
5634         case MATCH_ERROR:
5635           return MATCH_ERROR;
5636         }
5637
5638     next_item:
5639       if (gfc_match_eos () == MATCH_YES)
5640         break;
5641       if (gfc_match_char (',') != MATCH_YES)
5642         goto syntax;
5643     }
5644
5645   return MATCH_YES;
5646
5647 syntax:
5648   gfc_error ("Syntax error in VALUE statement at %C");
5649   return MATCH_ERROR;
5650 }
5651
5652
5653 match
5654 gfc_match_volatile (void)
5655 {
5656   gfc_symbol *sym;
5657   match m;
5658
5659   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
5660       == FAILURE)
5661     return MATCH_ERROR;
5662
5663   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5664     {
5665       return MATCH_ERROR;
5666     }
5667
5668   if (gfc_match_eos () == MATCH_YES)
5669     goto syntax;
5670
5671   for(;;)
5672     {
5673       /* VOLATILE is special because it can be added to host-associated
5674          symbols locally.  */
5675       m = gfc_match_symbol (&sym, 1);
5676       switch (m)
5677         {
5678         case MATCH_YES:
5679           if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
5680               == FAILURE)
5681             return MATCH_ERROR;
5682           goto next_item;
5683
5684         case MATCH_NO:
5685           break;
5686
5687         case MATCH_ERROR:
5688           return MATCH_ERROR;
5689         }
5690
5691     next_item:
5692       if (gfc_match_eos () == MATCH_YES)
5693         break;
5694       if (gfc_match_char (',') != MATCH_YES)
5695         goto syntax;
5696     }
5697
5698   return MATCH_YES;
5699
5700 syntax:
5701   gfc_error ("Syntax error in VOLATILE statement at %C");
5702   return MATCH_ERROR;
5703 }
5704
5705
5706 /* Match a module procedure statement.  Note that we have to modify
5707    symbols in the parent's namespace because the current one was there
5708    to receive symbols that are in an interface's formal argument list.  */
5709
5710 match
5711 gfc_match_modproc (void)
5712 {
5713   char name[GFC_MAX_SYMBOL_LEN + 1];
5714   gfc_symbol *sym;
5715   match m;
5716   gfc_namespace *module_ns;
5717
5718   if (gfc_state_stack->state != COMP_INTERFACE
5719       || gfc_state_stack->previous == NULL
5720       || current_interface.type == INTERFACE_NAMELESS
5721       || current_interface.type == INTERFACE_ABSTRACT)
5722     {
5723       gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5724                  "interface");
5725       return MATCH_ERROR;
5726     }
5727
5728   module_ns = gfc_current_ns->parent;
5729   for (; module_ns; module_ns = module_ns->parent)
5730     if (module_ns->proc_name->attr.flavor == FL_MODULE)
5731       break;
5732
5733   if (module_ns == NULL)
5734     return MATCH_ERROR;
5735
5736   for (;;)
5737     {
5738       m = gfc_match_name (name);
5739       if (m == MATCH_NO)
5740         goto syntax;
5741       if (m != MATCH_YES)
5742         return MATCH_ERROR;
5743
5744       if (gfc_get_symbol (name, module_ns, &sym))
5745         return MATCH_ERROR;
5746
5747       if (sym->attr.proc != PROC_MODULE
5748           && gfc_add_procedure (&sym->attr, PROC_MODULE,
5749                                 sym->name, NULL) == FAILURE)
5750         return MATCH_ERROR;
5751
5752       if (gfc_add_interface (sym) == FAILURE)
5753         return MATCH_ERROR;
5754
5755       sym->attr.mod_proc = 1;
5756
5757       if (gfc_match_eos () == MATCH_YES)
5758         break;
5759       if (gfc_match_char (',') != MATCH_YES)
5760         goto syntax;
5761     }
5762
5763   return MATCH_YES;
5764
5765 syntax:
5766   gfc_syntax_error (ST_MODULE_PROC);
5767   return MATCH_ERROR;
5768 }
5769
5770
5771 /* Match the optional attribute specifiers for a type declaration.
5772    Return MATCH_ERROR if an error is encountered in one of the handled
5773    attributes (public, private, bind(c)), MATCH_NO if what's found is
5774    not a handled attribute, and MATCH_YES otherwise.  TODO: More error
5775    checking on attribute conflicts needs to be done.  */
5776
5777 match
5778 gfc_get_type_attr_spec (symbol_attribute *attr)
5779 {
5780   /* See if the derived type is marked as private.  */
5781   if (gfc_match (" , private") == MATCH_YES)
5782     {
5783       if (gfc_current_state () != COMP_MODULE)
5784         {
5785           gfc_error ("Derived type at %C can only be PRIVATE in the "
5786                      "specification part of a module");
5787           return MATCH_ERROR;
5788         }
5789
5790       if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
5791         return MATCH_ERROR;
5792     }
5793   else if (gfc_match (" , public") == MATCH_YES)
5794     {
5795       if (gfc_current_state () != COMP_MODULE)
5796         {
5797           gfc_error ("Derived type at %C can only be PUBLIC in the "
5798                      "specification part of a module");
5799           return MATCH_ERROR;
5800         }
5801
5802       if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
5803         return MATCH_ERROR;
5804     }
5805   else if (gfc_match(" , bind ( c )") == MATCH_YES)
5806     {
5807       /* If the type is defined to be bind(c) it then needs to make
5808          sure that all fields are interoperable.  This will
5809          need to be a semantic check on the finished derived type.
5810          See 15.2.3 (lines 9-12) of F2003 draft.  */
5811       if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
5812         return MATCH_ERROR;
5813
5814       /* TODO: attr conflicts need to be checked, probably in symbol.c.  */
5815     }
5816   else
5817     return MATCH_NO;
5818
5819   /* If we get here, something matched.  */
5820   return MATCH_YES;
5821 }
5822
5823
5824 /* Match the beginning of a derived type declaration.  If a type name
5825    was the result of a function, then it is possible to have a symbol
5826    already to be known as a derived type yet have no components.  */
5827
5828 match
5829 gfc_match_derived_decl (void)
5830 {
5831   char name[GFC_MAX_SYMBOL_LEN + 1];
5832   symbol_attribute attr;
5833   gfc_symbol *sym;
5834   match m;
5835   match is_type_attr_spec = MATCH_NO;
5836   bool seen_attr = false;
5837
5838   if (gfc_current_state () == COMP_DERIVED)
5839     return MATCH_NO;
5840
5841   gfc_clear_attr (&attr);
5842
5843   do
5844     {
5845       is_type_attr_spec = gfc_get_type_attr_spec (&attr);
5846       if (is_type_attr_spec == MATCH_ERROR)
5847         return MATCH_ERROR;
5848       if (is_type_attr_spec == MATCH_YES)
5849         seen_attr = true;
5850     } while (is_type_attr_spec == MATCH_YES);
5851
5852   if (gfc_match (" ::") != MATCH_YES && seen_attr)
5853     {
5854       gfc_error ("Expected :: in TYPE definition at %C");
5855       return MATCH_ERROR;
5856     }
5857
5858   m = gfc_match (" %n%t", name);
5859   if (m != MATCH_YES)
5860     return m;
5861
5862   /* Make sure the name is not the name of an intrinsic type.  */
5863   if (gfc_is_intrinsic_typename (name))
5864     {
5865       gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5866                  "type", name);
5867       return MATCH_ERROR;
5868     }
5869
5870   if (gfc_get_symbol (name, NULL, &sym))
5871     return MATCH_ERROR;
5872
5873   if (sym->ts.type != BT_UNKNOWN)
5874     {
5875       gfc_error ("Derived type name '%s' at %C already has a basic type "
5876                  "of %s", sym->name, gfc_typename (&sym->ts));
5877       return MATCH_ERROR;
5878     }
5879
5880   /* The symbol may already have the derived attribute without the
5881      components.  The ways this can happen is via a function
5882      definition, an INTRINSIC statement or a subtype in another
5883      derived type that is a pointer.  The first part of the AND clause
5884      is true if a the symbol is not the return value of a function.  */
5885   if (sym->attr.flavor != FL_DERIVED
5886       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
5887     return MATCH_ERROR;
5888
5889   if (sym->components != NULL || sym->attr.zero_comp)
5890     {
5891       gfc_error ("Derived type definition of '%s' at %C has already been "
5892                  "defined", sym->name);
5893       return MATCH_ERROR;
5894     }
5895
5896   if (attr.access != ACCESS_UNKNOWN
5897       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
5898     return MATCH_ERROR;
5899
5900   /* See if the derived type was labeled as bind(c).  */
5901   if (attr.is_bind_c != 0)
5902     sym->attr.is_bind_c = attr.is_bind_c;
5903
5904   gfc_new_block = sym;
5905
5906   return MATCH_YES;
5907 }
5908
5909
5910 /* Cray Pointees can be declared as:
5911       pointer (ipt, a (n,m,...,*))
5912    By default, this is treated as an AS_ASSUMED_SIZE array.  We'll
5913    cheat and set a constant bound of 1 for the last dimension, if this
5914    is the case. Since there is no bounds-checking for Cray Pointees,
5915    this will be okay.  */
5916
5917 try
5918 gfc_mod_pointee_as (gfc_array_spec *as)
5919 {
5920   as->cray_pointee = true; /* This will be useful to know later.  */
5921   if (as->type == AS_ASSUMED_SIZE)
5922     {
5923       as->type = AS_EXPLICIT;
5924       as->upper[as->rank - 1] = gfc_int_expr (1);
5925       as->cp_was_assumed = true;
5926     }
5927   else if (as->type == AS_ASSUMED_SHAPE)
5928     {
5929       gfc_error ("Cray Pointee at %C cannot be assumed shape array");
5930       return MATCH_ERROR;
5931     }
5932   return MATCH_YES;
5933 }
5934
5935
5936 /* Match the enum definition statement, here we are trying to match
5937    the first line of enum definition statement.
5938    Returns MATCH_YES if match is found.  */
5939
5940 match
5941 gfc_match_enum (void)
5942 {
5943   match m;
5944
5945   m = gfc_match_eos ();
5946   if (m != MATCH_YES)
5947     return m;
5948
5949   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
5950       == FAILURE)
5951     return MATCH_ERROR;
5952
5953   return MATCH_YES;
5954 }
5955
5956
5957 /* Match a variable name with an optional initializer.  When this
5958    subroutine is called, a variable is expected to be parsed next.
5959    Depending on what is happening at the moment, updates either the
5960    symbol table or the current interface.  */
5961
5962 static match
5963 enumerator_decl (void)
5964 {
5965   char name[GFC_MAX_SYMBOL_LEN + 1];
5966   gfc_expr *initializer;
5967   gfc_array_spec *as = NULL;
5968   gfc_symbol *sym;
5969   locus var_locus;
5970   match m;
5971   try t;
5972   locus old_locus;
5973
5974   initializer = NULL;
5975   old_locus = gfc_current_locus;
5976
5977   /* When we get here, we've just matched a list of attributes and
5978      maybe a type and a double colon.  The next thing we expect to see
5979      is the name of the symbol.  */
5980   m = gfc_match_name (name);
5981   if (m != MATCH_YES)
5982     goto cleanup;
5983
5984   var_locus = gfc_current_locus;
5985
5986   /* OK, we've successfully matched the declaration.  Now put the
5987      symbol in the current namespace. If we fail to create the symbol,
5988      bail out.  */
5989   if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
5990     {
5991       m = MATCH_ERROR;
5992       goto cleanup;
5993     }
5994
5995   /* The double colon must be present in order to have initializers.
5996      Otherwise the statement is ambiguous with an assignment statement.  */
5997   if (colon_seen)
5998     {
5999       if (gfc_match_char ('=') == MATCH_YES)
6000         {
6001           m = gfc_match_init_expr (&initializer);
6002           if (m == MATCH_NO)
6003             {
6004               gfc_error ("Expected an initialization expression at %C");
6005               m = MATCH_ERROR;
6006             }
6007
6008           if (m != MATCH_YES)
6009             goto cleanup;
6010         }
6011     }
6012
6013   /* If we do not have an initializer, the initialization value of the
6014      previous enumerator (stored in last_initializer) is incremented
6015      by 1 and is used to initialize the current enumerator.  */
6016   if (initializer == NULL)
6017     initializer = gfc_enum_initializer (last_initializer, old_locus);
6018
6019   if (initializer == NULL || initializer->ts.type != BT_INTEGER)
6020     {
6021       gfc_error("ENUMERATOR %L not initialized with integer expression",
6022                 &var_locus);
6023       m = MATCH_ERROR;
6024       gfc_free_enum_history ();
6025       goto cleanup;
6026     }
6027
6028   /* Store this current initializer, for the next enumerator variable
6029      to be parsed.  add_init_expr_to_sym() zeros initializer, so we
6030      use last_initializer below.  */
6031   last_initializer = initializer;
6032   t = add_init_expr_to_sym (name, &initializer, &var_locus);
6033
6034   /* Maintain enumerator history.  */
6035   gfc_find_symbol (name, NULL, 0, &sym);
6036   create_enum_history (sym, last_initializer);
6037
6038   return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
6039
6040 cleanup:
6041   /* Free stuff up and return.  */
6042   gfc_free_expr (initializer);
6043
6044   return m;
6045 }
6046
6047
6048 /* Match the enumerator definition statement.  */
6049
6050 match
6051 gfc_match_enumerator_def (void)
6052 {
6053   match m;
6054   try t;
6055
6056   gfc_clear_ts (&current_ts);
6057
6058   m = gfc_match (" enumerator");
6059   if (m != MATCH_YES)
6060     return m;
6061
6062   m = gfc_match (" :: ");
6063   if (m == MATCH_ERROR)
6064     return m;
6065
6066   colon_seen = (m == MATCH_YES);
6067
6068   if (gfc_current_state () != COMP_ENUM)
6069     {
6070       gfc_error ("ENUM definition statement expected before %C");
6071       gfc_free_enum_history ();
6072       return MATCH_ERROR;
6073     }
6074
6075   (&current_ts)->type = BT_INTEGER;
6076   (&current_ts)->kind = gfc_c_int_kind;
6077
6078   gfc_clear_attr (&current_attr);
6079   t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
6080   if (t == FAILURE)
6081     {
6082       m = MATCH_ERROR;
6083       goto cleanup;
6084     }
6085
6086   for (;;)
6087     {
6088       m = enumerator_decl ();
6089       if (m == MATCH_ERROR)
6090         goto cleanup;
6091       if (m == MATCH_NO)
6092         break;
6093
6094       if (gfc_match_eos () == MATCH_YES)
6095         goto cleanup;
6096       if (gfc_match_char (',') != MATCH_YES)
6097         break;
6098     }
6099
6100   if (gfc_current_state () == COMP_ENUM)
6101     {
6102       gfc_free_enum_history ();
6103       gfc_error ("Syntax error in ENUMERATOR definition at %C");
6104       m = MATCH_ERROR;
6105     }
6106
6107 cleanup:
6108   gfc_free_array_spec (current_as);
6109   current_as = NULL;
6110   return m;
6111
6112 }
6113