gcc/fortran/decl.c

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