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           /* Character strings are only C interoperable if they have a
 843              length of 1.  */
 844           if (sym->ts.type == BT_CHARACTER)
 845             {
 846               gfc_charlen *cl = sym->ts.cl;
 847               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
 848                   || mpz_cmp_si (cl->length->value.integer, 1) != 0)
 849                 {
 850                   gfc_error ("Character argument '%s' at %L "
 851                              "must be length 1 because "
 852                              "procedure '%s' is BIND(C)",
 853                              sym->name, &sym->declared_at,
 854                              sym->ns->proc_name->name);
 855                   retval = FAILURE;
 856                 }
 857             }
 858
 859           /* We have to make sure that any param to a bind(c) routine does
 860              not have the allocatable, pointer, or optional attributes,
 861              according to J3/04-007, section 5.1.  */
 862           if (sym->attr.allocatable == 1)
 863             {
 864               gfc_error ("Variable '%s' at %L cannot have the "
 865                          "ALLOCATABLE attribute because procedure '%s'"
 866                          " is BIND(C)", sym->name, &(sym->declared_at),
 867                          sym->ns->proc_name->name);
 868               retval = FAILURE;
 869             }
 870
 871           if (sym->attr.pointer == 1)
 872             {
 873               gfc_error ("Variable '%s' at %L cannot have the "
 874                          "POINTER attribute because procedure '%s'"
 875                          " is BIND(C)", sym->name, &(sym->declared_at),
 876                          sym->ns->proc_name->name);
 877               retval = FAILURE;
 878             }
 879
 880           if (sym->attr.optional == 1)
 881             {
 882               gfc_error ("Variable '%s' at %L cannot have the "
 883                          "OPTIONAL attribute because procedure '%s'"
 884                          " is BIND(C)", sym->name, &(sym->declared_at),
 885                          sym->ns->proc_name->name);
 886               retval = FAILURE;
 887             }
 888
 889           /* Make sure that if it has the dimension attribute, that it is
 890              either assumed size or explicit shape.  */
 891           if (sym->as != NULL)
 892             {
 893               if (sym->as->type == AS_ASSUMED_SHAPE)
 894                 {
 895                   gfc_error ("Assumed-shape array '%s' at %L cannot be an "
 896                              "argument to the procedure '%s' at %L because "
 897                              "the procedure is BIND(C)", sym->name,
 898                              &(sym->declared_at), sym->ns->proc_name->name,
 899                              &(sym->ns->proc_name->declared_at));
 900                   retval = FAILURE;
 901                 }
 902
 903               if (sym->as->type == AS_DEFERRED)
 904                 {
 905                   gfc_error ("Deferred-shape array '%s' at %L cannot be an "
 906                              "argument to the procedure '%s' at %L because "
 907                              "the procedure is BIND(C)", sym->name,
 908                              &(sym->declared_at), sym->ns->proc_name->name,
 909                              &(sym->ns->proc_name->declared_at));
 910                   retval = FAILURE;
 911                 }
 912           }
 913         }
 914     }
 915
 916   return retval;
 917 }
 918
 919
 920 /* Function called by variable_decl() that adds a name to the symbol table.  */
 921
 922 static try
 923 build_sym (const char *name, gfc_charlen *cl,
 924            gfc_array_spec **as, locus *var_locus)
 925 {
 926   symbol_attribute attr;
 927   gfc_symbol *sym;
 928
 929   if (gfc_get_symbol (name, NULL, &sym))
 930     return FAILURE;
 931
 932   /* Start updating the symbol table.  Add basic type attribute if present.  */
 933   if (current_ts.type != BT_UNKNOWN
 934       && (sym->attr.implicit_type == 0
 935           || !gfc_compare_types (&sym->ts, &current_ts))
 936       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
 937     return FAILURE;
 938
 939   if (sym->ts.type == BT_CHARACTER)
 940     sym->ts.cl = cl;
 941
 942   /* Add dimension attribute if present.  */
 943   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
 944     return FAILURE;
 945   *as = NULL;
 946
 947   /* Add attribute to symbol.  The copy is so that we can reset the
 948      dimension attribute.  */
 949   attr = current_attr;
 950   attr.dimension = 0;
 951
 952   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
 953     return FAILURE;
 954
 955   /* Finish any work that may need to be done for the binding label,
 956      if it's a bind(c).  The bind(c) attr is found before the symbol
 957      is made, and before the symbol name (for data decls), so the
 958      current_ts is holding the binding label, or nothing if the
 959      name= attr wasn't given.  Therefore, test here if we're dealing
 960      with a bind(c) and make sure the binding label is set correctly.  */
 961   if (sym->attr.is_bind_c == 1)
 962     {
 963       if (sym->binding_label[0] == '\0')
 964         {
 965           /* Here, we're not checking the numIdents (the last param).
 966              This could be an error we're letting slip through!  */
 967           if (set_binding_label (sym->binding_label, sym->name, 1) == FAILURE)
 968             return FAILURE;
 969         }
 970     }
 971
 972   /* See if we know we're in a common block, and if it's a bind(c)
 973      common then we need to make sure we're an interoperable type.  */
 974   if (sym->attr.in_common == 1)
 975     {
 976       /* Test the common block object.  */
 977       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
 978           && sym->ts.is_c_interop != 1)
 979         {
 980           gfc_error_now ("Variable '%s' in common block '%s' at %C "
 981                          "must be declared with a C interoperable "
 982                          "kind since common block '%s' is BIND(C)",
 983                          sym->name, sym->common_block->name,
 984                          sym->common_block->name);
 985           gfc_clear_error ();
 986         }
 987     }
 988
 989   sym->attr.implied_index = 0;
 990
 991   return SUCCESS;
 992 }
 993
 994
 995 /* Set character constant to the given length. The constant will be padded or
 996    truncated.  */
 997
 998 void
 999 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
1000 {
1001   char *s;
1002   int slen;
1003
1004   gcc_assert (expr->expr_type == EXPR_CONSTANT);
1005   gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
1006
1007   slen = expr->value.character.length;
1008   if (len != slen)
1009     {
1010       s = gfc_getmem (len + 1);
1011       memcpy (s, expr->value.character.string, MIN (len, slen));
1012       if (len > slen)
1013         memset (&s[slen], ' ', len - slen);
1014
1015       if (gfc_option.warn_character_truncation && slen > len)
1016         gfc_warning_now ("CHARACTER expression at %L is being truncated "
1017                          "(%d/%d)", &expr->where, slen, len);
1018
1019       /* Apply the standard by 'hand' otherwise it gets cleared for
1020          initializers.  */
1021       if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
1022         gfc_error_now ("The CHARACTER elements of the array constructor "
1023                        "at %L must have the same length (%d/%d)",
1024                         &expr->where, slen, len);
1025
1026       s[len] = '\0';
1027       gfc_free (expr->value.character.string);
1028       expr->value.character.string = s;
1029       expr->value.character.length = len;
1030     }
1031 }
1032
1033
1034 /* Function to create and update the enumerator history
1035    using the information passed as arguments.
1036    Pointer "max_enum" is also updated, to point to
1037    enum history node containing largest initializer.
1038
1039    SYM points to the symbol node of enumerator.
1040    INIT points to its enumerator value.  */
1041
1042 static void
1043 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1044 {
1045   enumerator_history *new_enum_history;
1046   gcc_assert (sym != NULL && init != NULL);
1047
1048   new_enum_history = gfc_getmem (sizeof (enumerator_history));
1049
1050   new_enum_history->sym = sym;
1051   new_enum_history->initializer = init;
1052   new_enum_history->next = NULL;
1053
1054   if (enum_history == NULL)
1055     {
1056       enum_history = new_enum_history;
1057       max_enum = enum_history;
1058     }
1059   else
1060     {
1061       new_enum_history->next = enum_history;
1062       enum_history = new_enum_history;
1063
1064       if (mpz_cmp (max_enum->initializer->value.integer,
1065                    new_enum_history->initializer->value.integer) < 0)
1066         max_enum = new_enum_history;
1067     }
1068 }
1069
1070
1071 /* Function to free enum kind history.  */
1072
1073 void
1074 gfc_free_enum_history (void)
1075 {
1076   enumerator_history *current = enum_history;
1077   enumerator_history *next;
1078
1079   while (current != NULL)
1080     {
1081       next = current->next;
1082       gfc_free (current);
1083       current = next;
1084     }
1085   max_enum = NULL;
1086   enum_history = NULL;
1087 }
1088
1089
1090 /* Function called by variable_decl() that adds an initialization
1091    expression to a symbol.  */
1092
1093 static try
1094 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1095 {
1096   symbol_attribute attr;
1097   gfc_symbol *sym;
1098   gfc_expr *init;
1099
1100   init = *initp;
1101   if (find_special (name, &sym))
1102     return FAILURE;
1103
1104   attr = sym->attr;
1105
1106   /* If this symbol is confirming an implicit parameter type,
1107      then an initialization expression is not allowed.  */
1108   if (attr.flavor == FL_PARAMETER
1109       && sym->value != NULL
1110       && *initp != NULL)
1111     {
1112       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1113                  sym->name);
1114       return FAILURE;
1115     }
1116
1117   if (attr.in_common
1118       && !attr.data
1119       && *initp != NULL)
1120     {
1121       gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1122                  sym->name);
1123       return FAILURE;
1124     }
1125
1126   if (init == NULL)
1127     {
1128       /* An initializer is required for PARAMETER declarations.  */
1129       if (attr.flavor == FL_PARAMETER)
1130         {
1131           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1132           return FAILURE;
1133         }
1134     }
1135   else
1136     {
1137       /* If a variable appears in a DATA block, it cannot have an
1138          initializer.  */
1139       if (sym->attr.data)
1140         {
1141           gfc_error ("Variable '%s' at %C with an initializer already "
1142                      "appears in a DATA statement", sym->name);
1143           return FAILURE;
1144         }
1145
1146       /* Check if the assignment can happen. This has to be put off
1147          until later for a derived type variable.  */
1148       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1149           && gfc_check_assign_symbol (sym, init) == FAILURE)
1150         return FAILURE;
1151
1152       if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1153         {
1154           /* Update symbol character length according initializer.  */
1155           if (sym->ts.cl->length == NULL)
1156             {
1157               /* If there are multiple CHARACTER variables declared on the
1158                  same line, we don't want them to share the same length.  */
1159               sym->ts.cl = gfc_get_charlen ();
1160               sym->ts.cl->next = gfc_current_ns->cl_list;
1161               gfc_current_ns->cl_list = sym->ts.cl;
1162
1163               if (sym->attr.flavor == FL_PARAMETER
1164                   && init->expr_type == EXPR_ARRAY)
1165                 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
1166             }
1167           /* Update initializer character length according symbol.  */
1168           else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1169             {
1170               int len = mpz_get_si (sym->ts.cl->length->value.integer);
1171               gfc_constructor * p;
1172
1173               if (init->expr_type == EXPR_CONSTANT)
1174                 gfc_set_constant_character_len (len, init, false);
1175               else if (init->expr_type == EXPR_ARRAY)
1176                 {
1177                   /* Build a new charlen to prevent simplification from
1178                      deleting the length before it is resolved.  */
1179                   init->ts.cl = gfc_get_charlen ();
1180                   init->ts.cl->next = gfc_current_ns->cl_list;
1181                   gfc_current_ns->cl_list = sym->ts.cl;
1182                   init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
1183
1184                   for (p = init->value.constructor; p; p = p->next)
1185                     gfc_set_constant_character_len (len, p->expr, false);
1186                 }
1187             }
1188         }
1189
1190       /* Need to check if the expression we initialized this
1191          to was one of the iso_c_binding named constants.  If so,
1192          and we're a parameter (constant), let it be iso_c.
1193          For example:
1194          integer(c_int), parameter :: my_int = c_int
1195          integer(my_int) :: my_int_2
1196          If we mark my_int as iso_c (since we can see it's value
1197          is equal to one of the named constants), then my_int_2
1198          will be considered C interoperable.  */
1199       if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1200         {
1201           sym->ts.is_iso_c |= init->ts.is_iso_c;
1202           sym->ts.is_c_interop |= init->ts.is_c_interop;
1203           /* attr bits needed for module files.  */
1204           sym->attr.is_iso_c |= init->ts.is_iso_c;
1205           sym->attr.is_c_interop |= init->ts.is_c_interop;
1206           if (init->ts.is_iso_c)
1207             sym->ts.f90_type = init->ts.f90_type;
1208         }
1209
1210       /* Add initializer.  Make sure we keep the ranks sane.  */
1211       if (sym->attr.dimension && init->rank == 0)
1212         {
1213           mpz_t size;
1214           gfc_expr *array;
1215           gfc_constructor *c;
1216           int n;
1217           if (sym->attr.flavor == FL_PARAMETER
1218                 && init->expr_type == EXPR_CONSTANT
1219                 && spec_size (sym->as, &size) == SUCCESS
1220                 && mpz_cmp_si (size, 0) > 0)
1221             {
1222               array = gfc_start_constructor (init->ts.type, init->ts.kind,
1223                                              &init->where);
1224
1225               array->value.constructor = c = NULL;
1226               for (n = 0; n < (int)mpz_get_si (size); n++)
1227                 {
1228                   if (array->value.constructor == NULL)
1229                     {
1230                       array->value.constructor = c = gfc_get_constructor ();
1231                       c->expr = init;
1232                     }
1233                   else
1234                     {
1235                       c->next = gfc_get_constructor ();
1236                       c = c->next;
1237                       c->expr = gfc_copy_expr (init);
1238                     }
1239                 }
1240
1241               array->shape = gfc_get_shape (sym->as->rank);
1242               for (n = 0; n < sym->as->rank; n++)
1243                 spec_dimen_size (sym->as, n, &array->shape[n]);
1244
1245               init = array;
1246               mpz_clear (size);
1247             }
1248           init->rank = sym->as->rank;
1249         }
1250
1251       sym->value = init;
1252       if (sym->attr.save == SAVE_NONE)
1253         sym->attr.save = SAVE_IMPLICIT;
1254       *initp = NULL;
1255     }
1256
1257   return SUCCESS;
1258 }
1259
1260
1261 /* Function called by variable_decl() that adds a name to a structure
1262    being built.  */
1263
1264 static try
1265 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1266               gfc_array_spec **as)
1267 {
1268   gfc_component *c;
1269
1270   /* If the current symbol is of the same derived type that we're
1271      constructing, it must have the pointer attribute.  */
1272   if (current_ts.type == BT_DERIVED
1273       && current_ts.derived == gfc_current_block ()
1274       && current_attr.pointer == 0)
1275     {
1276       gfc_error ("Component at %C must have the POINTER attribute");
1277       return FAILURE;
1278     }
1279
1280   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1281     {
1282       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1283         {
1284           gfc_error ("Array component of structure at %C must have explicit "
1285                      "or deferred shape");
1286           return FAILURE;
1287         }
1288     }
1289
1290   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1291     return FAILURE;
1292
1293   c->ts = current_ts;
1294   c->ts.cl = cl;
1295   gfc_set_component_attr (c, &current_attr);
1296
1297   c->initializer = *init;
1298   *init = NULL;
1299
1300   c->as = *as;
1301   if (c->as != NULL)
1302     c->dimension = 1;
1303   *as = NULL;
1304
1305   /* Check array components.  */
1306   if (!c->dimension)
1307     {
1308       if (c->allocatable)
1309         {
1310           gfc_error ("Allocatable component at %C must be an array");
1311           return FAILURE;
1312         }
1313       else
1314         return SUCCESS;
1315     }
1316
1317   if (c->pointer)
1318     {
1319       if (c->as->type != AS_DEFERRED)
1320         {
1321           gfc_error ("Pointer array component of structure at %C must have a "
1322                      "deferred shape");
1323           return FAILURE;
1324         }
1325     }
1326   else if (c->allocatable)
1327     {
1328       if (c->as->type != AS_DEFERRED)
1329         {
1330           gfc_error ("Allocatable component of structure at %C must have a "
1331                      "deferred shape");
1332           return FAILURE;
1333         }
1334     }
1335   else
1336     {
1337       if (c->as->type != AS_EXPLICIT)
1338         {
1339           gfc_error ("Array component of structure at %C must have an "
1340                      "explicit shape");
1341           return FAILURE;
1342         }
1343     }
1344
1345   return SUCCESS;
1346 }
1347
1348
1349 /* Match a 'NULL()', and possibly take care of some side effects.  */
1350
1351 match
1352 gfc_match_null (gfc_expr **result)
1353 {
1354   gfc_symbol *sym;
1355   gfc_expr *e;
1356   match m;
1357
1358   m = gfc_match (" null ( )");
1359   if (m != MATCH_YES)
1360     return m;
1361
1362   /* The NULL symbol now has to be/become an intrinsic function.  */
1363   if (gfc_get_symbol ("null", NULL, &sym))
1364     {
1365       gfc_error ("NULL() initialization at %C is ambiguous");
1366       return MATCH_ERROR;
1367     }
1368
1369   gfc_intrinsic_symbol (sym);
1370
1371   if (sym->attr.proc != PROC_INTRINSIC
1372       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1373                              sym->name, NULL) == FAILURE
1374           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1375     return MATCH_ERROR;
1376
1377   e = gfc_get_expr ();
1378   e->where = gfc_current_locus;
1379   e->expr_type = EXPR_NULL;
1380   e->ts.type = BT_UNKNOWN;
1381
1382   *result = e;
1383
1384   return MATCH_YES;
1385 }
1386
1387
1388 /* Match a variable name with an optional initializer.  When this
1389    subroutine is called, a variable is expected to be parsed next.
1390    Depending on what is happening at the moment, updates either the
1391    symbol table or the current interface.  */
1392
1393 static match
1394 variable_decl (int elem)
1395 {
1396   char name[GFC_MAX_SYMBOL_LEN + 1];
1397   gfc_expr *initializer, *char_len;
1398   gfc_array_spec *as;
1399   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1400   gfc_charlen *cl;
1401   locus var_locus;
1402   match m;
1403   try t;
1404   gfc_symbol *sym;
1405   locus old_locus;
1406
1407   initializer = NULL;
1408   as = NULL;
1409   cp_as = NULL;
1410   old_locus = gfc_current_locus;
1411
1412   /* When we get here, we've just matched a list of attributes and
1413      maybe a type and a double colon.  The next thing we expect to see
1414      is the name of the symbol.  */
1415   m = gfc_match_name (name);
1416   if (m != MATCH_YES)
1417     goto cleanup;
1418
1419   var_locus = gfc_current_locus;
1420
1421   /* Now we could see the optional array spec. or character length.  */
1422   m = gfc_match_array_spec (&as);
1423   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1424     cp_as = gfc_copy_array_spec (as);
1425   else if (m == MATCH_ERROR)
1426     goto cleanup;
1427
1428   if (m == MATCH_NO)
1429     as = gfc_copy_array_spec (current_as);
1430
1431   char_len = NULL;
1432   cl = NULL;
1433
1434   if (current_ts.type == BT_CHARACTER)
1435     {
1436       switch (match_char_length (&char_len))
1437         {
1438         case MATCH_YES:
1439           cl = gfc_get_charlen ();
1440           cl->next = gfc_current_ns->cl_list;
1441           gfc_current_ns->cl_list = cl;
1442
1443           cl->length = char_len;
1444           break;
1445
1446         /* Non-constant lengths need to be copied after the first
1447            element.  */
1448         case MATCH_NO:
1449           if (elem > 1 && current_ts.cl->length
1450               && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1451             {
1452               cl = gfc_get_charlen ();
1453               cl->next = gfc_current_ns->cl_list;
1454               gfc_current_ns->cl_list = cl;
1455               cl->length = gfc_copy_expr (current_ts.cl->length);
1456             }
1457           else
1458             cl = current_ts.cl;
1459
1460           break;
1461
1462         case MATCH_ERROR:
1463           goto cleanup;
1464         }
1465     }
1466
1467   /*  If this symbol has already shown up in a Cray Pointer declaration,
1468       then we want to set the type & bail out.  */
1469   if (gfc_option.flag_cray_pointer)
1470     {
1471       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1472       if (sym != NULL && sym->attr.cray_pointee)
1473         {
1474           sym->ts.type = current_ts.type;
1475           sym->ts.kind = current_ts.kind;
1476           sym->ts.cl = cl;
1477           sym->ts.derived = current_ts.derived;
1478           sym->ts.is_c_interop = current_ts.is_c_interop;
1479           sym->ts.is_iso_c = current_ts.is_iso_c;
1480           m = MATCH_YES;
1481
1482           /* Check to see if we have an array specification.  */
1483           if (cp_as != NULL)
1484             {
1485               if (sym->as != NULL)
1486                 {
1487                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1488                   gfc_free_array_spec (cp_as);
1489                   m = MATCH_ERROR;
1490                   goto cleanup;
1491                 }
1492               else
1493                 {
1494                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1495                     gfc_internal_error ("Couldn't set pointee array spec.");
1496
1497                   /* Fix the array spec.  */
1498                   m = gfc_mod_pointee_as (sym->as);
1499                   if (m == MATCH_ERROR)
1500                     goto cleanup;
1501                 }
1502             }
1503           goto cleanup;
1504         }
1505       else
1506         {
1507           gfc_free_array_spec (cp_as);
1508         }
1509     }
1510
1511
1512   /* OK, we've successfully matched the declaration.  Now put the
1513      symbol in the current namespace, because it might be used in the
1514      optional initialization expression for this symbol, e.g. this is
1515      perfectly legal:
1516
1517      integer, parameter :: i = huge(i)
1518
1519      This is only true for parameters or variables of a basic type.
1520      For components of derived types, it is not true, so we don't
1521      create a symbol for those yet.  If we fail to create the symbol,
1522      bail out.  */
1523   if (gfc_current_state () != COMP_DERIVED
1524       && build_sym (name, cl, &as, &var_locus) == FAILURE)
1525     {
1526       m = MATCH_ERROR;
1527       goto cleanup;
1528     }
1529
1530   /* An interface body specifies all of the procedure's
1531      characteristics and these shall be consistent with those
1532      specified in the procedure definition, except that the interface
1533      may specify a procedure that is not pure if the procedure is
1534      defined to be pure(12.3.2).  */
1535   if (current_ts.type == BT_DERIVED
1536       && gfc_current_ns->proc_name
1537       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1538       && current_ts.derived->ns != gfc_current_ns
1539       && !gfc_current_ns->has_import_set)
1540     {
1541       gfc_error ("the type of '%s' at %C has not been declared within the "
1542                  "interface", name);
1543       m = MATCH_ERROR;
1544       goto cleanup;
1545     }
1546
1547   /* In functions that have a RESULT variable defined, the function
1548      name always refers to function calls.  Therefore, the name is
1549      not allowed to appear in specification statements.  */
1550   if (gfc_current_state () == COMP_FUNCTION
1551       && gfc_current_block () != NULL
1552       && gfc_current_block ()->result != NULL
1553       && gfc_current_block ()->result != gfc_current_block ()
1554       && strcmp (gfc_current_block ()->name, name) == 0)
1555     {
1556       gfc_error ("Function name '%s' not allowed at %C", name);
1557       m = MATCH_ERROR;
1558       goto cleanup;
1559     }
1560
1561   /* We allow old-style initializations of the form
1562        integer i /2/, j(4) /3*3, 1/
1563      (if no colon has been seen). These are different from data
1564      statements in that initializers are only allowed to apply to the
1565      variable immediately preceding, i.e.
1566        integer i, j /1, 2/
1567      is not allowed. Therefore we have to do some work manually, that
1568      could otherwise be left to the matchers for DATA statements.  */
1569
1570   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1571     {
1572       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1573                           "initialization at %C") == FAILURE)
1574         return MATCH_ERROR;
1575
1576       return match_old_style_init (name);
1577     }
1578
1579   /* The double colon must be present in order to have initializers.
1580      Otherwise the statement is ambiguous with an assignment statement.  */
1581   if (colon_seen)
1582     {
1583       if (gfc_match (" =>") == MATCH_YES)
1584         {
1585           if (!current_attr.pointer)
1586             {
1587               gfc_error ("Initialization at %C isn't for a pointer variable");
1588               m = MATCH_ERROR;
1589               goto cleanup;
1590             }
1591
1592           m = gfc_match_null (&initializer);
1593           if (m == MATCH_NO)
1594             {
1595               gfc_error ("Pointer initialization requires a NULL() at %C");
1596               m = MATCH_ERROR;
1597             }
1598
1599           if (gfc_pure (NULL))
1600             {
1601               gfc_error ("Initialization of pointer at %C is not allowed in "
1602                          "a PURE procedure");
1603               m = MATCH_ERROR;
1604             }
1605
1606           if (m != MATCH_YES)
1607             goto cleanup;
1608
1609         }
1610       else if (gfc_match_char ('=') == MATCH_YES)
1611         {
1612           if (current_attr.pointer)
1613             {
1614               gfc_error ("Pointer initialization at %C requires '=>', "
1615                          "not '='");
1616               m = MATCH_ERROR;
1617               goto cleanup;
1618             }
1619
1620           m = gfc_match_init_expr (&initializer);
1621           if (m == MATCH_NO)
1622             {
1623               gfc_error ("Expected an initialization expression at %C");
1624               m = MATCH_ERROR;
1625             }
1626
1627           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1628             {
1629               gfc_error ("Initialization of variable at %C is not allowed in "
1630                          "a PURE procedure");
1631               m = MATCH_ERROR;
1632             }
1633
1634           if (m != MATCH_YES)
1635             goto cleanup;
1636         }
1637     }
1638
1639   if (initializer != NULL && current_attr.allocatable
1640         && gfc_current_state () == COMP_DERIVED)
1641     {
1642       gfc_error ("Initialization of allocatable component at %C is not "
1643                  "allowed");
1644       m = MATCH_ERROR;
1645       goto cleanup;
1646     }
1647
1648   /* Add the initializer.  Note that it is fine if initializer is
1649      NULL here, because we sometimes also need to check if a
1650      declaration *must* have an initialization expression.  */
1651   if (gfc_current_state () != COMP_DERIVED)
1652     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1653   else
1654     {
1655       if (current_ts.type == BT_DERIVED
1656           && !current_attr.pointer && !initializer)
1657         initializer = gfc_default_initializer (&current_ts);
1658       t = build_struct (name, cl, &initializer, &as);
1659     }
1660
1661   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1662
1663 cleanup:
1664   /* Free stuff up and return.  */
1665   gfc_free_expr (initializer);
1666   gfc_free_array_spec (as);
1667
1668   return m;
1669 }
1670
1671
1672 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1673    This assumes that the byte size is equal to the kind number for
1674    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
1675
1676 match
1677 gfc_match_old_kind_spec (gfc_typespec *ts)
1678 {
1679   match m;
1680   int original_kind;
1681
1682   if (gfc_match_char ('*') != MATCH_YES)
1683     return MATCH_NO;
1684
1685   m = gfc_match_small_literal_int (&ts->kind, NULL);
1686   if (m != MATCH_YES)
1687     return MATCH_ERROR;
1688
1689   original_kind = ts->kind;
1690
1691   /* Massage the kind numbers for complex types.  */
1692   if (ts->type == BT_COMPLEX)
1693     {
1694       if (ts->kind % 2)
1695         {
1696           gfc_error ("Old-style type declaration %s*%d not supported at %C",
1697                      gfc_basic_typename (ts->type), original_kind);
1698           return MATCH_ERROR;
1699         }
1700       ts->kind /= 2;
1701     }
1702
1703   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1704     {
1705       gfc_error ("Old-style type declaration %s*%d not supported at %C",
1706                  gfc_basic_typename (ts->type), original_kind);
1707       return MATCH_ERROR;
1708     }
1709
1710   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1711                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
1712     return MATCH_ERROR;
1713
1714   return MATCH_YES;
1715 }
1716
1717
1718 /* Match a kind specification.  Since kinds are generally optional, we
1719    usually return MATCH_NO if something goes wrong.  If a "kind="
1720    string is found, then we know we have an error.  */
1721
1722 match
1723 gfc_match_kind_spec (gfc_typespec *ts)
1724 {
1725   locus where;
1726   gfc_expr *e;
1727   match m, n;
1728   const char *msg;
1729
1730   m = MATCH_NO;
1731   e = NULL;
1732
1733   where = gfc_current_locus;
1734
1735   if (gfc_match_char ('(') == MATCH_NO)
1736     return MATCH_NO;
1737
1738   /* Also gobbles optional text.  */
1739   if (gfc_match (" kind = ") == MATCH_YES)
1740     m = MATCH_ERROR;
1741
1742   n = gfc_match_init_expr (&e);
1743   if (n == MATCH_NO)
1744     gfc_error ("Expected initialization expression at %C");
1745   if (n != MATCH_YES)
1746     return MATCH_ERROR;
1747
1748   if (e->rank != 0)
1749     {
1750       gfc_error ("Expected scalar initialization expression at %C");
1751       m = MATCH_ERROR;
1752       goto no_match;
1753     }
1754
1755   msg = gfc_extract_int (e, &ts->kind);
1756   if (msg != NULL)
1757     {
1758       gfc_error (msg);
1759       m = MATCH_ERROR;
1760       goto no_match;
1761     }
1762
1763   /* Before throwing away the expression, let's see if we had a
1764      C interoperable kind (and store the fact).  */
1765   if (e->ts.is_c_interop == 1)
1766     {
1767       /* Mark this as c interoperable if being declared with one
1768          of the named constants from iso_c_binding.  */
1769       ts->is_c_interop = e->ts.is_iso_c;
1770       ts->f90_type = e->ts.f90_type;
1771     }
1772
1773   gfc_free_expr (e);
1774   e = NULL;
1775
1776   /* Ignore errors to this point, if we've gotten here.  This means
1777      we ignore the m=MATCH_ERROR from above.  */
1778   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1779     {
1780       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1781                  gfc_basic_typename (ts->type));
1782       m = MATCH_ERROR;
1783     }
1784   else if (gfc_match_char (')') != MATCH_YES)
1785     {
1786       gfc_error ("Missing right parenthesis at %C");
1787      m = MATCH_ERROR;
1788     }
1789   else
1790      /* All tests passed.  */
1791      m = MATCH_YES;
1792
1793   if(m == MATCH_ERROR)
1794      gfc_current_locus = where;
1795
1796   /* Return what we know from the test(s).  */
1797   return m;
1798
1799 no_match:
1800   gfc_free_expr (e);
1801   gfc_current_locus = where;
1802   return m;
1803 }
1804
1805
1806 /* Match the various kind/length specifications in a CHARACTER
1807    declaration.  We don't return MATCH_NO.  */
1808
1809 static match
1810 match_char_spec (gfc_typespec *ts)
1811 {
1812   int kind, seen_length;
1813   gfc_charlen *cl;
1814   gfc_expr *len;
1815   match m;
1816   gfc_expr *kind_expr = NULL;
1817   kind = gfc_default_character_kind;
1818   len = NULL;
1819   seen_length = 0;
1820
1821   /* Try the old-style specification first.  */
1822   old_char_selector = 0;
1823
1824   m = match_char_length (&len);
1825   if (m != MATCH_NO)
1826     {
1827       if (m == MATCH_YES)
1828         old_char_selector = 1;
1829       seen_length = 1;
1830       goto done;
1831     }
1832
1833   m = gfc_match_char ('(');
1834   if (m != MATCH_YES)
1835     {
1836       m = MATCH_YES;    /* Character without length is a single char.  */
1837       goto done;
1838     }
1839
1840   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
1841   if (gfc_match (" kind =") == MATCH_YES)
1842     {
1843       m = gfc_match_small_int_expr(&kind, &kind_expr);
1844
1845       if (m == MATCH_ERROR)
1846         goto done;
1847       if (m == MATCH_NO)
1848         goto syntax;
1849
1850       if (gfc_match (" , len =") == MATCH_NO)
1851         goto rparen;
1852
1853       m = char_len_param_value (&len);
1854       if (m == MATCH_NO)
1855         goto syntax;
1856       if (m == MATCH_ERROR)
1857         goto done;
1858       seen_length = 1;
1859
1860       goto rparen;
1861     }
1862
1863   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
1864   if (gfc_match (" len =") == MATCH_YES)
1865     {
1866       m = char_len_param_value (&len);
1867       if (m == MATCH_NO)
1868         goto syntax;
1869       if (m == MATCH_ERROR)
1870         goto done;
1871       seen_length = 1;
1872
1873       if (gfc_match_char (')') == MATCH_YES)
1874         goto done;
1875
1876       if (gfc_match (" , kind =") != MATCH_YES)
1877         goto syntax;
1878
1879       gfc_match_small_int_expr(&kind, &kind_expr);
1880
1881       if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1882         {
1883           gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1884           return MATCH_YES;
1885         }
1886
1887       goto rparen;
1888     }
1889
1890   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
1891   m = char_len_param_value (&len);
1892   if (m == MATCH_NO)
1893     goto syntax;
1894   if (m == MATCH_ERROR)
1895     goto done;
1896   seen_length = 1;
1897
1898   m = gfc_match_char (')');
1899   if (m == MATCH_YES)
1900     goto done;
1901
1902   if (gfc_match_char (',') != MATCH_YES)
1903     goto syntax;
1904
1905   gfc_match (" kind =");        /* Gobble optional text.  */
1906
1907   m = gfc_match_small_int_expr(&kind, &kind_expr);
1908   if (m == MATCH_ERROR)
1909     goto done;
1910   if (m == MATCH_NO)
1911     goto syntax;
1912
1913 rparen:
1914   /* Require a right-paren at this point.  */
1915   m = gfc_match_char (')');
1916   if (m == MATCH_YES)
1917     goto done;
1918
1919 syntax:
1920   gfc_error ("Syntax error in CHARACTER declaration at %C");
1921   m = MATCH_ERROR;
1922   gfc_free_expr (len);
1923   return m;
1924
1925 done:
1926   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1927     {
1928       gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1929       m = MATCH_ERROR;
1930     }
1931
1932   if (seen_length == 1 && len != NULL
1933       && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN)
1934     {
1935       gfc_error ("Expression at %C must be of INTEGER type");
1936       m = MATCH_ERROR;
1937     }
1938
1939   if (m != MATCH_YES)
1940     {
1941       gfc_free_expr (len);
1942       gfc_free_expr (kind_expr);
1943       return m;
1944     }
1945
1946   /* Do some final massaging of the length values.  */
1947   cl = gfc_get_charlen ();
1948   cl->next = gfc_current_ns->cl_list;
1949   gfc_current_ns->cl_list = cl;
1950
1951   if (seen_length == 0)
1952     cl->length = gfc_int_expr (1);
1953   else
1954     cl->length = len;
1955
1956   ts->cl = cl;
1957   ts->kind = kind;
1958
1959   /* We have to know if it was a c interoperable kind so we can
1960      do accurate type checking of bind(c) procs, etc.  */
1961   if (kind_expr != NULL)
1962     {
1963       /* Mark this as c interoperable if being declared with one
1964          of the named constants from iso_c_binding.  */
1965       ts->is_c_interop = kind_expr->ts.is_iso_c;
1966       gfc_free_expr (kind_expr);
1967     }
1968   else if (len != NULL)
1969     {
1970       /* Here, we might have parsed something such as:
1971          character(c_char)
1972          In this case, the parsing code above grabs the c_char when
1973          looking for the length (line 1690, roughly).  it's the last
1974          testcase for parsing the kind params of a character variable.
1975          However, it's not actually the length.  this seems like it
1976          could be an error.
1977          To see if the user used a C interop kind, test the expr
1978          of the so called length, and see if it's C interoperable.  */
1979       ts->is_c_interop = len->ts.is_iso_c;
1980     }
1981
1982   return MATCH_YES;
1983 }
1984
1985
1986 /* Matches a type specification.  If successful, sets the ts structure
1987    to the matched specification.  This is necessary for FUNCTION and
1988    IMPLICIT statements.
1989
1990    If implicit_flag is nonzero, then we don't check for the optional
1991    kind specification.  Not doing so is needed for matching an IMPLICIT
1992    statement correctly.  */
1993
1994 static match
1995 match_type_spec (gfc_typespec *ts, int implicit_flag)
1996 {
1997   char name[GFC_MAX_SYMBOL_LEN + 1];
1998   gfc_symbol *sym;
1999   match m;
2000   int c;
2001
2002   gfc_clear_ts (ts);
2003
2004   /* Clear the current binding label, in case one is given.  */
2005   curr_binding_label[0] = '\0';
2006
2007   if (gfc_match (" byte") == MATCH_YES)
2008     {
2009       if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
2010           == FAILURE)
2011         return MATCH_ERROR;
2012
2013       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2014         {
2015           gfc_error ("BYTE type used at %C "
2016                      "is not available on the target machine");
2017           return MATCH_ERROR;
2018         }
2019
2020       ts->type = BT_INTEGER;
2021       ts->kind = 1;
2022       return MATCH_YES;
2023     }
2024
2025   if (gfc_match (" integer") == MATCH_YES)
2026     {
2027       ts->type = BT_INTEGER;
2028       ts->kind = gfc_default_integer_kind;
2029       goto get_kind;
2030     }
2031
2032   if (gfc_match (" character") == MATCH_YES)
2033     {
2034       ts->type = BT_CHARACTER;
2035       if (implicit_flag == 0)
2036         return match_char_spec (ts);
2037       else
2038         return MATCH_YES;
2039     }
2040
2041   if (gfc_match (" real") == MATCH_YES)
2042     {
2043       ts->type = BT_REAL;
2044       ts->kind = gfc_default_real_kind;
2045       goto get_kind;
2046     }
2047
2048   if (gfc_match (" double precision") == MATCH_YES)
2049     {
2050       ts->type = BT_REAL;
2051       ts->kind = gfc_default_double_kind;
2052       return MATCH_YES;
2053     }
2054
2055   if (gfc_match (" complex") == MATCH_YES)
2056     {
2057       ts->type = BT_COMPLEX;
2058       ts->kind = gfc_default_complex_kind;
2059       goto get_kind;
2060     }
2061
2062   if (gfc_match (" double complex") == MATCH_YES)
2063     {
2064       if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2065                           "conform to the Fortran 95 standard") == FAILURE)
2066         return MATCH_ERROR;
2067
2068       ts->type = BT_COMPLEX;
2069       ts->kind = gfc_default_double_kind;
2070       return MATCH_YES;
2071     }
2072
2073   if (gfc_match (" logical") == MATCH_YES)
2074     {
2075       ts->type = BT_LOGICAL;
2076       ts->kind = gfc_default_logical_kind;
2077       goto get_kind;
2078     }
2079
2080   m = gfc_match (" type ( %n )", name);
2081   if (m != MATCH_YES)
2082     return m;
2083
2084   /* Search for the name but allow the components to be defined later.  */
2085   if (gfc_get_ha_symbol (name, &sym))
2086     {
2087       gfc_error ("Type name '%s' at %C is ambiguous", name);
2088       return MATCH_ERROR;
2089     }
2090
2091   if (sym->attr.flavor != FL_DERIVED
2092       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2093     return MATCH_ERROR;
2094
2095   ts->type = BT_DERIVED;
2096   ts->kind = 0;
2097   ts->derived = sym;
2098
2099   return MATCH_YES;
2100
2101 get_kind:
2102   /* For all types except double, derived and character, look for an
2103      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2104   if (implicit_flag == 1)
2105     return MATCH_YES;
2106
2107   if (gfc_current_form == FORM_FREE)
2108     {
2109       c = gfc_peek_char();
2110       if (!gfc_is_whitespace(c) && c != '*' && c != '('
2111           && c != ':' && c != ',')
2112        return MATCH_NO;
2113     }
2114
2115   m = gfc_match_kind_spec (ts);
2116   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2117     m = gfc_match_old_kind_spec (ts);
2118
2119   if (m == MATCH_NO)
2120     m = MATCH_YES;              /* No kind specifier found.  */
2121
2122   return m;
2123 }
2124
2125
2126 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2127    already matched in parse.c, or we would not end up here in the
2128    first place.  So the only thing we need to check, is if there is
2129    trailing garbage.  If not, the match is successful.  */
2130
2131 match
2132 gfc_match_implicit_none (void)
2133 {
2134   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2135 }
2136
2137
2138 /* Match the letter range(s) of an IMPLICIT statement.  */
2139
2140 static match
2141 match_implicit_range (void)
2142 {
2143   int c, c1, c2, inner;
2144   locus cur_loc;
2145
2146   cur_loc = gfc_current_locus;
2147
2148   gfc_gobble_whitespace ();
2149   c = gfc_next_char ();
2150   if (c != '(')
2151     {
2152       gfc_error ("Missing character range in IMPLICIT at %C");
2153       goto bad;
2154     }
2155
2156   inner = 1;
2157   while (inner)
2158     {
2159       gfc_gobble_whitespace ();
2160       c1 = gfc_next_char ();
2161       if (!ISALPHA (c1))
2162         goto bad;
2163
2164       gfc_gobble_whitespace ();
2165       c = gfc_next_char ();
2166
2167       switch (c)
2168         {
2169         case ')':
2170           inner = 0;            /* Fall through.  */
2171
2172         case ',':
2173           c2 = c1;
2174           break;
2175
2176         case '-':
2177           gfc_gobble_whitespace ();
2178           c2 = gfc_next_char ();
2179           if (!ISALPHA (c2))
2180             goto bad;
2181
2182           gfc_gobble_whitespace ();
2183           c = gfc_next_char ();
2184
2185           if ((c != ',') && (c != ')'))
2186             goto bad;
2187           if (c == ')')
2188             inner = 0;
2189
2190           break;
2191
2192         default:
2193           goto bad;
2194         }
2195
2196       if (c1 > c2)
2197         {
2198           gfc_error ("Letters must be in alphabetic order in "
2199                      "IMPLICIT statement at %C");
2200           goto bad;
2201         }
2202
2203       /* See if we can add the newly matched range to the pending
2204          implicits from this IMPLICIT statement.  We do not check for
2205          conflicts with whatever earlier IMPLICIT statements may have
2206          set.  This is done when we've successfully finished matching
2207          the current one.  */
2208       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2209         goto bad;
2210     }
2211
2212   return MATCH_YES;
2213
2214 bad:
2215   gfc_syntax_error (ST_IMPLICIT);
2216
2217   gfc_current_locus = cur_loc;
2218   return MATCH_ERROR;
2219 }
2220
2221
2222 /* Match an IMPLICIT statement, storing the types for
2223    gfc_set_implicit() if the statement is accepted by the parser.
2224    There is a strange looking, but legal syntactic construction
2225    possible.  It looks like:
2226
2227      IMPLICIT INTEGER (a-b) (c-d)
2228
2229    This is legal if "a-b" is a constant expression that happens to
2230    equal one of the legal kinds for integers.  The real problem
2231    happens with an implicit specification that looks like:
2232
2233      IMPLICIT INTEGER (a-b)
2234
2235    In this case, a typespec matcher that is "greedy" (as most of the
2236    matchers are) gobbles the character range as a kindspec, leaving
2237    nothing left.  We therefore have to go a bit more slowly in the
2238    matching process by inhibiting the kindspec checking during
2239    typespec matching and checking for a kind later.  */
2240
2241 match
2242 gfc_match_implicit (void)
2243 {
2244   gfc_typespec ts;
2245   locus cur_loc;
2246   int c;
2247   match m;
2248
2249   /* We don't allow empty implicit statements.  */
2250   if (gfc_match_eos () == MATCH_YES)
2251     {
2252       gfc_error ("Empty IMPLICIT statement at %C");
2253       return MATCH_ERROR;
2254     }
2255
2256   do
2257     {
2258       /* First cleanup.  */
2259       gfc_clear_new_implicit ();
2260
2261       /* A basic type is mandatory here.  */
2262       m = match_type_spec (&ts, 1);
2263       if (m == MATCH_ERROR)
2264         goto error;
2265       if (m == MATCH_NO)
2266         goto syntax;
2267
2268       cur_loc = gfc_current_locus;
2269       m = match_implicit_range ();
2270
2271       if (m == MATCH_YES)
2272         {
2273           /* We may have <TYPE> (<RANGE>).  */
2274           gfc_gobble_whitespace ();
2275           c = gfc_next_char ();
2276           if ((c == '\n') || (c == ','))
2277             {
2278               /* Check for CHARACTER with no length parameter.  */
2279               if (ts.type == BT_CHARACTER && !ts.cl)
2280                 {
2281                   ts.kind = gfc_default_character_kind;
2282                   ts.cl = gfc_get_charlen ();
2283                   ts.cl->next = gfc_current_ns->cl_list;
2284                   gfc_current_ns->cl_list = ts.cl;
2285                   ts.cl->length = gfc_int_expr (1);
2286                 }
2287
2288               /* Record the Successful match.  */
2289               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2290                 return MATCH_ERROR;
2291               continue;
2292             }
2293
2294           gfc_current_locus = cur_loc;
2295         }
2296
2297       /* Discard the (incorrectly) matched range.  */
2298       gfc_clear_new_implicit ();
2299
2300       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2301       if (ts.type == BT_CHARACTER)
2302         m = match_char_spec (&ts);
2303       else
2304         {
2305           m = gfc_match_kind_spec (&ts);
2306           if (m == MATCH_NO)
2307             {
2308               m = gfc_match_old_kind_spec (&ts);
2309               if (m == MATCH_ERROR)
2310                 goto error;
2311               if (m == MATCH_NO)
2312                 goto syntax;
2313             }
2314         }
2315       if (m == MATCH_ERROR)
2316         goto error;
2317
2318       m = match_implicit_range ();
2319       if (m == MATCH_ERROR)
2320         goto error;
2321       if (m == MATCH_NO)
2322         goto syntax;
2323
2324       gfc_gobble_whitespace ();
2325       c = gfc_next_char ();
2326       if ((c != '\n') && (c != ','))
2327         goto syntax;
2328
2329       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2330         return MATCH_ERROR;
2331     }
2332   while (c == ',');
2333
2334   return MATCH_YES;
2335
2336 syntax:
2337   gfc_syntax_error (ST_IMPLICIT);
2338
2339 error:
2340   return MATCH_ERROR;
2341 }
2342
2343
2344 match
2345 gfc_match_import (void)
2346 {
2347   char name[GFC_MAX_SYMBOL_LEN + 1];
2348   match m;
2349   gfc_symbol *sym;
2350   gfc_symtree *st;
2351
2352   if (gfc_current_ns->proc_name == NULL
2353       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2354     {
2355       gfc_error ("IMPORT statement at %C only permitted in "
2356                  "an INTERFACE body");
2357       return MATCH_ERROR;
2358     }
2359
2360   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2361       == FAILURE)
2362     return MATCH_ERROR;
2363
2364   if (gfc_match_eos () == MATCH_YES)
2365     {
2366       /* All host variables should be imported.  */
2367       gfc_current_ns->has_import_set = 1;
2368       return MATCH_YES;
2369     }
2370
2371   if (gfc_match (" ::") == MATCH_YES)
2372     {
2373       if (gfc_match_eos () == MATCH_YES)
2374         {
2375            gfc_error ("Expecting list of named entities at %C");
2376            return MATCH_ERROR;
2377         }
2378     }
2379
2380   for(;;)
2381     {
2382       m = gfc_match (" %n", name);
2383       switch (m)
2384         {
2385         case MATCH_YES:
2386           if (gfc_current_ns->parent !=  NULL
2387               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2388             {
2389                gfc_error ("Type name '%s' at %C is ambiguous", name);
2390                return MATCH_ERROR;
2391             }
2392           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2393                    && gfc_find_symbol (name,
2394                                        gfc_current_ns->proc_name->ns->parent,
2395                                        1, &sym))
2396             {
2397                gfc_error ("Type name '%s' at %C is ambiguous", name);
2398                return MATCH_ERROR;
2399             }
2400
2401           if (sym == NULL)
2402             {
2403               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2404                          "at %C - does not exist.", name);
2405               return MATCH_ERROR;
2406             }
2407
2408           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2409             {
2410               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2411                            "at %C.", name);
2412               goto next_item;
2413             }
2414
2415           st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2416           st->n.sym = sym;
2417           sym->refs++;
2418           sym->ns = gfc_current_ns;
2419
2420           goto next_item;
2421
2422         case MATCH_NO:
2423           break;
2424
2425         case MATCH_ERROR:
2426           return MATCH_ERROR;
2427         }
2428
2429     next_item:
2430       if (gfc_match_eos () == MATCH_YES)
2431         break;
2432       if (gfc_match_char (',') != MATCH_YES)
2433         goto syntax;
2434     }
2435
2436   return MATCH_YES;
2437
2438 syntax:
2439   gfc_error ("Syntax error in IMPORT statement at %C");
2440   return MATCH_ERROR;
2441 }
2442
2443
2444 /* Matches an attribute specification including array specs.  If
2445    successful, leaves the variables current_attr and current_as
2446    holding the specification.  Also sets the colon_seen variable for
2447    later use by matchers associated with initializations.
2448
2449    This subroutine is a little tricky in the sense that we don't know
2450    if we really have an attr-spec until we hit the double colon.
2451    Until that time, we can only return MATCH_NO.  This forces us to
2452    check for duplicate specification at this level.  */
2453
2454 static match
2455 match_attr_spec (void)
2456 {
2457   /* Modifiers that can exist in a type statement.  */
2458   typedef enum
2459   { GFC_DECL_BEGIN = 0,
2460     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2461     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2462     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2463     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2464     DECL_IS_BIND_C, DECL_COLON, DECL_NONE,
2465     GFC_DECL_END /* Sentinel */
2466   }
2467   decl_types;
2468
2469 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2470 #define NUM_DECL GFC_DECL_END
2471
2472   static mstring decls[] = {
2473     minit (", allocatable", DECL_ALLOCATABLE),
2474     minit (", dimension", DECL_DIMENSION),
2475     minit (", external", DECL_EXTERNAL),
2476     minit (", intent ( in )", DECL_IN),
2477     minit (", intent ( out )", DECL_OUT),
2478     minit (", intent ( in out )", DECL_INOUT),
2479     minit (", intrinsic", DECL_INTRINSIC),
2480     minit (", optional", DECL_OPTIONAL),
2481     minit (", parameter", DECL_PARAMETER),
2482     minit (", pointer", DECL_POINTER),
2483     minit (", protected", DECL_PROTECTED),
2484     minit (", private", DECL_PRIVATE),
2485     minit (", public", DECL_PUBLIC),
2486     minit (", save", DECL_SAVE),
2487     minit (", target", DECL_TARGET),
2488     minit (", value", DECL_VALUE),
2489     minit (", volatile", DECL_VOLATILE),
2490     minit ("::", DECL_COLON),
2491     minit (NULL, DECL_NONE)
2492   };
2493
2494   locus start, seen_at[NUM_DECL];
2495   int seen[NUM_DECL];
2496   decl_types d;
2497   const char *attr;
2498   match m;
2499   try t;
2500   char peek_char;
2501
2502   gfc_clear_attr (&current_attr);
2503   start = gfc_current_locus;
2504
2505   current_as = NULL;
2506   colon_seen = 0;
2507
2508   /* See if we get all of the keywords up to the final double colon.  */
2509   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2510     seen[d] = 0;
2511
2512   for (;;)
2513     {
2514       d = (decl_types) gfc_match_strings (decls);
2515
2516       if (d == DECL_NONE)
2517         {
2518           /* See if we can find the bind(c) since all else failed.
2519              We need to skip over any whitespace and stop on the ','.  */
2520           gfc_gobble_whitespace ();
2521           peek_char = gfc_peek_char ();
2522           if (peek_char == ',')
2523             {
2524               /* Chomp the comma.  */
2525               peek_char = gfc_next_char ();
2526               /* Try and match the bind(c).  */
2527               if (gfc_match_bind_c (NULL) == MATCH_YES)
2528                 d = DECL_IS_BIND_C;
2529             }
2530         }
2531
2532       if (d == DECL_NONE || d == DECL_COLON)
2533         break;
2534
2535       seen[d]++;
2536       seen_at[d] = gfc_current_locus;
2537
2538       if (d == DECL_DIMENSION)
2539         {
2540           m = gfc_match_array_spec (&current_as);
2541
2542           if (m == MATCH_NO)
2543             {
2544               gfc_error ("Missing dimension specification at %C");
2545               m = MATCH_ERROR;
2546             }
2547
2548           if (m == MATCH_ERROR)
2549             goto cleanup;
2550         }
2551     }
2552
2553   /* No double colon, so assume that we've been looking at something
2554      else the whole time.  */
2555   if (d == DECL_NONE)
2556     {
2557       m = MATCH_NO;
2558       goto cleanup;
2559     }
2560
2561   /* Since we've seen a double colon, we have to be looking at an
2562      attr-spec.  This means that we can now issue errors.  */
2563   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2564     if (seen[d] > 1)
2565       {
2566         switch (d)
2567           {
2568           case DECL_ALLOCATABLE:
2569             attr = "ALLOCATABLE";
2570             break;
2571           case DECL_DIMENSION:
2572             attr = "DIMENSION";
2573             break;
2574           case DECL_EXTERNAL:
2575             attr = "EXTERNAL";
2576             break;
2577           case DECL_IN:
2578             attr = "INTENT (IN)";
2579             break;
2580           case DECL_OUT:
2581             attr = "INTENT (OUT)";
2582             break;
2583           case DECL_INOUT:
2584             attr = "INTENT (IN OUT)";
2585             break;
2586           case DECL_INTRINSIC:
2587             attr = "INTRINSIC";
2588             break;
2589           case DECL_OPTIONAL:
2590             attr = "OPTIONAL";
2591             break;
2592           case DECL_PARAMETER:
2593             attr = "PARAMETER";
2594             break;
2595           case DECL_POINTER:
2596             attr = "POINTER";
2597             break;
2598           case DECL_PROTECTED:
2599             attr = "PROTECTED";
2600             break;
2601           case DECL_PRIVATE:
2602             attr = "PRIVATE";
2603             break;
2604           case DECL_PUBLIC:
2605             attr = "PUBLIC";
2606             break;
2607           case DECL_SAVE:
2608             attr = "SAVE";
2609             break;
2610           case DECL_TARGET:
2611             attr = "TARGET";
2612             break;
2613           case DECL_IS_BIND_C:
2614             attr = "IS_BIND_C";
2615             break;
2616           case DECL_VALUE:
2617             attr = "VALUE";
2618             break;
2619           case DECL_VOLATILE:
2620             attr = "VOLATILE";
2621             break;
2622           default:
2623             attr = NULL;        /* This shouldn't happen.  */
2624           }
2625
2626         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2627         m = MATCH_ERROR;
2628         goto cleanup;
2629       }
2630
2631   /* Now that we've dealt with duplicate attributes, add the attributes
2632      to the current attribute.  */
2633   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2634     {
2635       if (seen[d] == 0)
2636         continue;
2637
2638       if (gfc_current_state () == COMP_DERIVED
2639           && d != DECL_DIMENSION && d != DECL_POINTER
2640           && d != DECL_COLON     && d != DECL_PRIVATE
2641           && d != DECL_PUBLIC    && d != DECL_NONE)
2642         {
2643           if (d == DECL_ALLOCATABLE)
2644             {
2645               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2646                                   "attribute at %C in a TYPE definition")
2647                   == FAILURE)
2648                 {
2649                   m = MATCH_ERROR;
2650                   goto cleanup;
2651                 }
2652             }
2653           else
2654             {
2655               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2656                          &seen_at[d]);
2657               m = MATCH_ERROR;
2658               goto cleanup;
2659             }
2660         }
2661
2662       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2663           && gfc_current_state () != COMP_MODULE)
2664         {
2665           if (d == DECL_PRIVATE)
2666             attr = "PRIVATE";
2667           else
2668             attr = "PUBLIC";
2669           if (gfc_current_state () == COMP_DERIVED
2670               && gfc_state_stack->previous
2671               && gfc_state_stack->previous->state == COMP_MODULE)
2672             {
2673               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2674                                   "at %L in a TYPE definition", attr,
2675                                   &seen_at[d])
2676                   == FAILURE)
2677                 {
2678                   m = MATCH_ERROR;
2679                   goto cleanup;
2680                 }
2681             }
2682           else
2683             {
2684               gfc_error ("%s attribute at %L is not allowed outside of the "
2685                          "specification part of a module", attr, &seen_at[d]);
2686               m = MATCH_ERROR;
2687               goto cleanup;
2688             }
2689         }
2690
2691       switch (d)
2692         {
2693         case DECL_ALLOCATABLE:
2694           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2695           break;
2696
2697         case DECL_DIMENSION:
2698           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
2699           break;
2700
2701         case DECL_EXTERNAL:
2702           t = gfc_add_external (&current_attr, &seen_at[d]);
2703           break;
2704
2705         case DECL_IN:
2706           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2707           break;
2708
2709         case DECL_OUT:
2710           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2711           break;
2712
2713         case DECL_INOUT:
2714           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2715           break;
2716
2717         case DECL_INTRINSIC:
2718           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2719           break;
2720
2721         case DECL_OPTIONAL:
2722           t = gfc_add_optional (&current_attr, &seen_at[d]);
2723           break;
2724
2725         case DECL_PARAMETER:
2726           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
2727           break;
2728
2729         case DECL_POINTER:
2730           t = gfc_add_pointer (&current_attr, &seen_at[d]);
2731           break;
2732
2733         case DECL_PROTECTED:
2734           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2735             {
2736                gfc_error ("PROTECTED at %C only allowed in specification "
2737                           "part of a module");
2738                t = FAILURE;
2739                break;
2740             }
2741
2742           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2743                               "attribute at %C")
2744               == FAILURE)
2745             t = FAILURE;
2746           else
2747             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
2748           break;
2749
2750         case DECL_PRIVATE:
2751           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2752                               &seen_at[d]);
2753           break;
2754
2755         case DECL_PUBLIC:
2756           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2757                               &seen_at[d]);
2758           break;
2759
2760         case DECL_SAVE:
2761           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
2762           break;
2763
2764         case DECL_TARGET:
2765           t = gfc_add_target (&current_attr, &seen_at[d]);
2766           break;
2767
2768         case DECL_IS_BIND_C:
2769            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
2770            break;
2771
2772         case DECL_VALUE:
2773           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2774                               "at %C")
2775               == FAILURE)
2776             t = FAILURE;
2777           else
2778             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
2779           break;
2780
2781         case DECL_VOLATILE:
2782           if (gfc_notify_std (GFC_STD_F2003,
2783                               "Fortran 2003: VOLATILE attribute at %C")
2784               == FAILURE)
2785             t = FAILURE;
2786           else
2787             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2788           break;
2789
2790         default:
2791           gfc_internal_error ("match_attr_spec(): Bad attribute");
2792         }
2793
2794       if (t == FAILURE)
2795         {
2796           m = MATCH_ERROR;
2797           goto cleanup;
2798         }
2799     }
2800
2801   colon_seen = 1;
2802   return MATCH_YES;
2803
2804 cleanup:
2805   gfc_current_locus = start;
2806   gfc_free_array_spec (current_as);
2807   current_as = NULL;
2808   return m;
2809 }
2810
2811
2812 /* Set the binding label, dest_label, either with the binding label
2813    stored in the given gfc_typespec, ts, or if none was provided, it
2814    will be the symbol name in all lower case, as required by the draft
2815    (J3/04-007, section 15.4.1).  If a binding label was given and
2816    there is more than one argument (num_idents), it is an error.  */
2817
2818 try
2819 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
2820 {
2821   if (curr_binding_label[0] != '\0')
2822     {
2823       if (num_idents > 1 || num_idents_on_line > 1)
2824         {
2825           gfc_error ("Multiple identifiers provided with "
2826                      "single NAME= specifier at %C");
2827           return FAILURE;
2828         }
2829
2830       /* Binding label given; store in temp holder til have sym.  */
2831       strncpy (dest_label, curr_binding_label,
2832                strlen (curr_binding_label) + 1);
2833     }
2834   else
2835     {
2836       /* No binding label given, and the NAME= specifier did not exist,
2837          which means there was no NAME="".  */
2838       if (sym_name != NULL && has_name_equals == 0)
2839         strncpy (dest_label, sym_name, strlen (sym_name) + 1);
2840     }
2841
2842   return SUCCESS;
2843 }
2844
2845
2846 /* Set the status of the given common block as being BIND(C) or not,
2847    depending on the given parameter, is_bind_c.  */
2848
2849 void
2850 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
2851 {
2852   com_block->is_bind_c = is_bind_c;
2853   return;
2854 }
2855
2856
2857 /* Verify that the given gfc_typespec is for a C interoperable type.  */
2858
2859 try
2860 verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
2861 {
2862   try t;
2863
2864   /* Make sure the kind used is appropriate for the type.
2865      The f90_type is unknown if an integer constant was
2866      used (e.g., real(4), bind(c) :: myFloat).  */
2867   if (ts->f90_type != BT_UNKNOWN)
2868     {
2869       t = gfc_validate_c_kind (ts);
2870       if (t != SUCCESS)
2871         {
2872           /* Print an error, but continue parsing line.  */
2873           gfc_error_now ("C kind parameter is for type %s but "
2874                          "symbol '%s' at %L is of type %s",
2875                          gfc_basic_typename (ts->f90_type),
2876                          name, where,
2877                          gfc_basic_typename (ts->type));
2878         }
2879     }
2880
2881   /* Make sure the kind is C interoperable.  This does not care about the
2882      possible error above.  */
2883   if (ts->type == BT_DERIVED && ts->derived != NULL)
2884     return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
2885   else if (ts->is_c_interop != 1)
2886     return FAILURE;
2887
2888   return SUCCESS;
2889 }
2890
2891
2892 /* Verify that the variables of a given common block, which has been
2893    defined with the attribute specifier bind(c), to be of a C
2894    interoperable type.  Errors will be reported here, if
2895    encountered.  */
2896
2897 try
2898 verify_com_block_vars_c_interop (gfc_common_head *com_block)
2899 {
2900   gfc_symbol *curr_sym = NULL;
2901   try retval = SUCCESS;
2902
2903   curr_sym = com_block->head;
2904
2905   /* Make sure we have at least one symbol.  */
2906   if (curr_sym == NULL)
2907     return retval;
2908
2909   /* Here we know we have a symbol, so we'll execute this loop
2910      at least once.  */
2911   do
2912     {
2913       /* The second to last param, 1, says this is in a common block.  */
2914       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
2915       curr_sym = curr_sym->common_next;
2916     } while (curr_sym != NULL);
2917
2918   return retval;
2919 }
2920
2921
2922 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
2923    an appropriate error message is reported.  */
2924
2925 try
2926 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
2927                    int is_in_common, gfc_common_head *com_block)
2928 {
2929   try retval = SUCCESS;
2930
2931   /* Here, we know we have the bind(c) attribute, so if we have
2932      enough type info, then verify that it's a C interop kind.
2933      The info could be in the symbol already, or possibly still in
2934      the given ts (current_ts), so look in both.  */
2935   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
2936     {
2937       if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
2938                             &(tmp_sym->declared_at)) != SUCCESS)
2939         {
2940           /* See if we're dealing with a sym in a common block or not.  */
2941           if (is_in_common == 1)
2942             {
2943               gfc_warning ("Variable '%s' in common block '%s' at %L "
2944                            "may not be a C interoperable "
2945                            "kind though common block '%s' is BIND(C)",
2946                            tmp_sym->name, com_block->name,
2947                            &(tmp_sym->declared_at), com_block->name);
2948             }
2949           else
2950             {
2951               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
2952                 gfc_error ("Type declaration '%s' at %L is not C "
2953                            "interoperable but it is BIND(C)",
2954                            tmp_sym->name, &(tmp_sym->declared_at));
2955               else
2956                 gfc_warning ("Variable '%s' at %L "
2957                              "may not be a C interoperable "
2958                              "kind but it is bind(c)",
2959                              tmp_sym->name, &(tmp_sym->declared_at));
2960             }
2961         }
2962
2963       /* Variables declared w/in a common block can't be bind(c)
2964          since there's no way for C to see these variables, so there's
2965          semantically no reason for the attribute.  */
2966       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
2967         {
2968           gfc_error ("Variable '%s' in common block '%s' at "
2969                      "%L cannot be declared with BIND(C) "
2970                      "since it is not a global",
2971                      tmp_sym->name, com_block->name,
2972                      &(tmp_sym->declared_at));
2973           retval = FAILURE;
2974         }
2975
2976       /* Scalar variables that are bind(c) can not have the pointer
2977          or allocatable attributes.  */
2978       if (tmp_sym->attr.is_bind_c == 1)
2979         {
2980           if (tmp_sym->attr.pointer == 1)
2981             {
2982               gfc_error ("Variable '%s' at %L cannot have both the "
2983                          "POINTER and BIND(C) attributes",
2984                          tmp_sym->name, &(tmp_sym->declared_at));
2985               retval = FAILURE;
2986             }
2987
2988           if (tmp_sym->attr.allocatable == 1)
2989             {
2990               gfc_error ("Variable '%s' at %L cannot have both the "
2991                          "ALLOCATABLE and BIND(C) attributes",
2992                          tmp_sym->name, &(tmp_sym->declared_at));
2993               retval = FAILURE;
2994             }
2995
2996           /* If it is a BIND(C) function, make sure the return value is a
2997              scalar value.  The previous tests in this function made sure
2998              the type is interoperable.  */
2999           if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3000             gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3001                        "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3002
3003           /* BIND(C) functions can not return a character string.  */
3004           if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3005             if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3006                 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3007                 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3008               gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3009                          "be a character string", tmp_sym->name,
3010                          &(tmp_sym->declared_at));
3011         }
3012     }
3013
3014   /* See if the symbol has been marked as private.  If it has, make sure
3015      there is no binding label and warn the user if there is one.  */
3016   if (tmp_sym->attr.access == ACCESS_PRIVATE
3017       && tmp_sym->binding_label[0] != '\0')
3018       /* Use gfc_warning_now because we won't say that the symbol fails
3019          just because of this.  */
3020       gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3021                        "given the binding label '%s'", tmp_sym->name,
3022                        &(tmp_sym->declared_at), tmp_sym->binding_label);
3023
3024   return retval;
3025 }
3026
3027
3028 /* Set the appropriate fields for a symbol that's been declared as
3029    BIND(C) (the is_bind_c flag and the binding label), and verify that
3030    the type is C interoperable.  Errors are reported by the functions
3031    used to set/test these fields.  */
3032
3033 try
3034 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3035 {
3036   try retval = SUCCESS;
3037
3038   /* TODO: Do we need to make sure the vars aren't marked private?  */
3039
3040   /* Set the is_bind_c bit in symbol_attribute.  */
3041   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3042
3043   if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3044                          num_idents) != SUCCESS)
3045     return FAILURE;
3046
3047   return retval;
3048 }
3049
3050
3051 /* Set the fields marking the given common block as BIND(C), including
3052    a binding label, and report any errors encountered.  */
3053
3054 try
3055 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3056 {
3057   try retval = SUCCESS;
3058
3059   /* destLabel, common name, typespec (which may have binding label).  */
3060   if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3061       != SUCCESS)
3062     return FAILURE;
3063
3064   /* Set the given common block (com_block) to being bind(c) (1).  */
3065   set_com_block_bind_c (com_block, 1);
3066
3067   return retval;
3068 }
3069
3070
3071 /* Retrieve the list of one or more identifiers that the given bind(c)
3072    attribute applies to.  */
3073
3074 try
3075 get_bind_c_idents (void)
3076 {
3077   char name[GFC_MAX_SYMBOL_LEN + 1];
3078   int num_idents = 0;
3079   gfc_symbol *tmp_sym = NULL;
3080   match found_id;
3081   gfc_common_head *com_block = NULL;
3082
3083   if (gfc_match_name (name) == MATCH_YES)
3084     {
3085       found_id = MATCH_YES;
3086       gfc_get_ha_symbol (name, &tmp_sym);
3087     }
3088   else if (match_common_name (name) == MATCH_YES)
3089     {
3090       found_id = MATCH_YES;
3091       com_block = gfc_get_common (name, 0);
3092     }
3093   else
3094     {
3095       gfc_error ("Need either entity or common block name for "
3096                  "attribute specification statement at %C");
3097       return FAILURE;
3098     }
3099
3100   /* Save the current identifier and look for more.  */
3101   do
3102     {
3103       /* Increment the number of identifiers found for this spec stmt.  */
3104       num_idents++;
3105
3106       /* Make sure we have a sym or com block, and verify that it can
3107          be bind(c).  Set the appropriate field(s) and look for more
3108          identifiers.  */
3109       if (tmp_sym != NULL || com_block != NULL)
3110         {
3111           if (tmp_sym != NULL)
3112             {
3113               if (set_verify_bind_c_sym (tmp_sym, num_idents)
3114                   != SUCCESS)
3115                 return FAILURE;
3116             }
3117           else
3118             {
3119               if (set_verify_bind_c_com_block(com_block, num_idents)
3120                   != SUCCESS)
3121                 return FAILURE;
3122             }
3123
3124           /* Look to see if we have another identifier.  */
3125           tmp_sym = NULL;
3126           if (gfc_match_eos () == MATCH_YES)
3127             found_id = MATCH_NO;
3128           else if (gfc_match_char (',') != MATCH_YES)
3129             found_id = MATCH_NO;
3130           else if (gfc_match_name (name) == MATCH_YES)
3131             {
3132               found_id = MATCH_YES;
3133               gfc_get_ha_symbol (name, &tmp_sym);
3134             }
3135           else if (match_common_name (name) == MATCH_YES)
3136             {
3137               found_id = MATCH_YES;
3138               com_block = gfc_get_common (name, 0);
3139             }
3140           else
3141             {
3142               gfc_error ("Missing entity or common block name for "
3143                          "attribute specification statement at %C");
3144               return FAILURE;
3145             }
3146         }
3147       else
3148         {
3149           gfc_internal_error ("Missing symbol");
3150         }
3151     } while (found_id == MATCH_YES);
3152
3153   /* if we get here we were successful */
3154   return SUCCESS;
3155 }
3156
3157
3158 /* Try and match a BIND(C) attribute specification statement.  */
3159
3160 match
3161 gfc_match_bind_c_stmt (void)
3162 {
3163   match found_match = MATCH_NO;
3164   gfc_typespec *ts;
3165
3166   ts = &current_ts;
3167
3168   /* This may not be necessary.  */
3169   gfc_clear_ts (ts);
3170   /* Clear the temporary binding label holder.  */
3171   curr_binding_label[0] = '\0';
3172
3173   /* Look for the bind(c).  */
3174   found_match = gfc_match_bind_c (NULL);
3175
3176   if (found_match == MATCH_YES)
3177     {
3178       /* Look for the :: now, but it is not required.  */
3179       gfc_match (" :: ");
3180
3181       /* Get the identifier(s) that needs to be updated.  This may need to
3182          change to hand the flag(s) for the attr specified so all identifiers
3183          found can have all appropriate parts updated (assuming that the same
3184          spec stmt can have multiple attrs, such as both bind(c) and
3185          allocatable...).  */
3186       if (get_bind_c_idents () != SUCCESS)
3187         /* Error message should have printed already.  */
3188         return MATCH_ERROR;
3189     }
3190
3191   return found_match;
3192 }
3193
3194
3195 /* Match a data declaration statement.  */
3196
3197 match
3198 gfc_match_data_decl (void)
3199 {
3200   gfc_symbol *sym;
3201   match m;
3202   int elem;
3203
3204   num_idents_on_line = 0;
3205
3206   m = match_type_spec (&current_ts, 0);
3207   if (m != MATCH_YES)
3208     return m;
3209
3210   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3211     {
3212       sym = gfc_use_derived (current_ts.derived);
3213
3214       if (sym == NULL)
3215         {
3216           m = MATCH_ERROR;
3217           goto cleanup;
3218         }
3219
3220       current_ts.derived = sym;
3221     }
3222
3223   m = match_attr_spec ();
3224   if (m == MATCH_ERROR)
3225     {
3226       m = MATCH_NO;
3227       goto cleanup;
3228     }
3229
3230   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
3231     {
3232
3233       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3234         goto ok;
3235
3236       gfc_find_symbol (current_ts.derived->name,
3237                        current_ts.derived->ns->parent, 1, &sym);
3238
3239       /* Any symbol that we find had better be a type definition
3240          which has its components defined.  */
3241       if (sym != NULL && sym->attr.flavor == FL_DERIVED
3242           && current_ts.derived->components != NULL)
3243         goto ok;
3244
3245       /* Now we have an error, which we signal, and then fix up
3246          because the knock-on is plain and simple confusing.  */
3247       gfc_error_now ("Derived type at %C has not been previously defined "
3248                      "and so cannot appear in a derived type definition");
3249       current_attr.pointer = 1;
3250       goto ok;
3251     }
3252
3253 ok:
3254   /* If we have an old-style character declaration, and no new-style
3255      attribute specifications, then there a comma is optional between
3256      the type specification and the variable list.  */
3257   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3258     gfc_match_char (',');
3259
3260   /* Give the types/attributes to symbols that follow. Give the element
3261      a number so that repeat character length expressions can be copied.  */
3262   elem = 1;
3263   for (;;)
3264     {
3265       num_idents_on_line++;
3266       m = variable_decl (elem++);
3267       if (m == MATCH_ERROR)
3268         goto cleanup;
3269       if (m == MATCH_NO)
3270         break;
3271
3272       if (gfc_match_eos () == MATCH_YES)
3273         goto cleanup;
3274       if (gfc_match_char (',') != MATCH_YES)
3275         break;
3276     }
3277
3278   if (gfc_error_flag_test () == 0)
3279     gfc_error ("Syntax error in data declaration at %C");
3280   m = MATCH_ERROR;
3281
3282   gfc_free_data_all (gfc_current_ns);
3283
3284 cleanup:
3285   gfc_free_array_spec (current_as);
3286   current_as = NULL;
3287   return m;
3288 }
3289
3290
3291 /* Match a prefix associated with a function or subroutine
3292    declaration.  If the typespec pointer is nonnull, then a typespec
3293    can be matched.  Note that if nothing matches, MATCH_YES is
3294    returned (the null string was matched).  */
3295
3296 static match
3297 match_prefix (gfc_typespec *ts)
3298 {
3299   int seen_type;
3300
3301   gfc_clear_attr (&current_attr);
3302   seen_type = 0;
3303
3304 loop:
3305   if (!seen_type && ts != NULL
3306       && match_type_spec (ts, 0) == MATCH_YES
3307       && gfc_match_space () == MATCH_YES)
3308     {
3309
3310       seen_type = 1;
3311       goto loop;
3312     }
3313
3314   if (gfc_match ("elemental% ") == MATCH_YES)
3315     {
3316       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3317         return MATCH_ERROR;
3318
3319       goto loop;
3320     }
3321
3322   if (gfc_match ("pure% ") == MATCH_YES)
3323     {
3324       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3325         return MATCH_ERROR;
3326
3327       goto loop;
3328     }
3329
3330   if (gfc_match ("recursive% ") == MATCH_YES)
3331     {
3332       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3333         return MATCH_ERROR;
3334
3335       goto loop;
3336     }
3337
3338   /* At this point, the next item is not a prefix.  */
3339   return MATCH_YES;
3340 }
3341
3342
3343 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
3344
3345 static try
3346 copy_prefix (symbol_attribute *dest, locus *where)
3347 {
3348   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3349     return FAILURE;
3350
3351   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3352     return FAILURE;
3353
3354   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3355     return FAILURE;
3356
3357   return SUCCESS;
3358 }
3359
3360
3361 /* Match a formal argument list.  */
3362
3363 match
3364 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3365 {
3366   gfc_formal_arglist *head, *tail, *p, *q;
3367   char name[GFC_MAX_SYMBOL_LEN + 1];
3368   gfc_symbol *sym;
3369   match m;
3370
3371   head = tail = NULL;
3372
3373   if (gfc_match_char ('(') != MATCH_YES)
3374     {
3375       if (null_flag)
3376         goto ok;
3377       return MATCH_NO;
3378     }
3379
3380   if (gfc_match_char (')') == MATCH_YES)
3381     goto ok;
3382
3383   for (;;)
3384     {
3385       if (gfc_match_char ('*') == MATCH_YES)
3386         sym = NULL;
3387       else
3388         {
3389           m = gfc_match_name (name);
3390           if (m != MATCH_YES)
3391             goto cleanup;
3392
3393           if (gfc_get_symbol (name, NULL, &sym))
3394             goto cleanup;
3395         }
3396
3397       p = gfc_get_formal_arglist ();
3398
3399       if (head == NULL)
3400         head = tail = p;
3401       else
3402         {
3403           tail->next = p;
3404           tail = p;
3405         }
3406
3407       tail->sym = sym;
3408
3409       /* We don't add the VARIABLE flavor because the name could be a
3410          dummy procedure.  We don't apply these attributes to formal
3411          arguments of statement functions.  */
3412       if (sym != NULL && !st_flag
3413           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3414               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3415         {
3416           m = MATCH_ERROR;
3417           goto cleanup;
3418         }
3419
3420       /* The name of a program unit can be in a different namespace,
3421          so check for it explicitly.  After the statement is accepted,
3422          the name is checked for especially in gfc_get_symbol().  */
3423       if (gfc_new_block != NULL && sym != NULL
3424           && strcmp (sym->name, gfc_new_block->name) == 0)
3425         {
3426           gfc_error ("Name '%s' at %C is the name of the procedure",
3427                      sym->name);
3428           m = MATCH_ERROR;
3429           goto cleanup;
3430         }
3431
3432       if (gfc_match_char (')') == MATCH_YES)
3433         goto ok;
3434
3435       m = gfc_match_char (',');
3436       if (m != MATCH_YES)
3437         {
3438           gfc_error ("Unexpected junk in formal argument list at %C");
3439           goto cleanup;
3440         }
3441     }
3442
3443 ok:
3444   /* Check for duplicate symbols in the formal argument list.  */
3445   if (head != NULL)
3446     {
3447       for (p = head; p->next; p = p->next)
3448         {
3449           if (p->sym == NULL)
3450             continue;
3451
3452           for (q = p->next; q; q = q->next)
3453             if (p->sym == q->sym)
3454               {
3455                 gfc_error ("Duplicate symbol '%s' in formal argument list "
3456                            "at %C", p->sym->name);
3457
3458                 m = MATCH_ERROR;
3459                 goto cleanup;
3460               }
3461         }
3462     }
3463
3464   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3465       == FAILURE)
3466     {
3467       m = MATCH_ERROR;
3468       goto cleanup;
3469     }
3470
3471   return MATCH_YES;
3472
3473 cleanup:
3474   gfc_free_formal_arglist (head);
3475   return m;
3476 }
3477
3478
3479 /* Match a RESULT specification following a function declaration or
3480    ENTRY statement.  Also matches the end-of-statement.  */
3481
3482 static match
3483 match_result (gfc_symbol *function, gfc_symbol **result)
3484 {
3485   char name[GFC_MAX_SYMBOL_LEN + 1];
3486   gfc_symbol *r;
3487   match m;
3488
3489   if (gfc_match (" result (") != MATCH_YES)
3490     return MATCH_NO;
3491
3492   m = gfc_match_name (name);
3493   if (m != MATCH_YES)
3494     return m;
3495
3496   /* Get the right paren, and that's it because there could be the
3497      bind(c) attribute after the result clause.  */
3498   if (gfc_match_char(')') != MATCH_YES)
3499     {
3500      /* TODO: should report the missing right paren here.  */
3501       return MATCH_ERROR;
3502     }
3503
3504   if (strcmp (function->name, name) == 0)
3505     {
3506       gfc_error ("RESULT variable at %C must be different than function name");
3507       return MATCH_ERROR;
3508     }
3509
3510   if (gfc_get_symbol (name, NULL, &r))
3511     return MATCH_ERROR;
3512
3513   if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3514       || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3515     return MATCH_ERROR;
3516
3517   *result = r;
3518
3519   return MATCH_YES;
3520 }
3521
3522
3523 /* Match a function suffix, which could be a combination of a result
3524    clause and BIND(C), either one, or neither.  The draft does not
3525    require them to come in a specific order.  */
3526
3527 match
3528 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3529 {
3530   match is_bind_c;   /* Found bind(c).  */
3531   match is_result;   /* Found result clause.  */
3532   match found_match; /* Status of whether we've found a good match.  */
3533   int peek_char;     /* Character we're going to peek at.  */
3534
3535   /* Initialize to having found nothing.  */
3536   found_match = MATCH_NO;
3537   is_bind_c = MATCH_NO;
3538   is_result = MATCH_NO;
3539
3540   /* Get the next char to narrow between result and bind(c).  */
3541   gfc_gobble_whitespace ();
3542   peek_char = gfc_peek_char ();
3543
3544   switch (peek_char)
3545     {
3546     case 'r':
3547       /* Look for result clause.  */
3548       is_result = match_result (sym, result);
3549       if (is_result == MATCH_YES)
3550         {
3551           /* Now see if there is a bind(c) after it.  */
3552           is_bind_c = gfc_match_bind_c (sym);
3553           /* We've found the result clause and possibly bind(c).  */
3554           found_match = MATCH_YES;
3555         }
3556       else
3557         /* This should only be MATCH_ERROR.  */
3558         found_match = is_result;
3559       break;
3560     case 'b':
3561       /* Look for bind(c) first.  */
3562       is_bind_c = gfc_match_bind_c (sym);
3563       if (is_bind_c == MATCH_YES)
3564         {
3565           /* Now see if a result clause followed it.  */
3566           is_result = match_result (sym, result);
3567           found_match = MATCH_YES;
3568         }
3569       else
3570         {
3571           /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
3572           found_match = MATCH_ERROR;
3573         }
3574       break;
3575     default:
3576       gfc_error ("Unexpected junk after function declaration at %C");
3577       found_match = MATCH_ERROR;
3578       break;
3579     }
3580
3581   if (is_result == MATCH_ERROR || is_bind_c == MATCH_ERROR)
3582     {
3583       gfc_error ("Error in function suffix at %C");
3584       return MATCH_ERROR;
3585     }
3586
3587   if (is_bind_c == MATCH_YES)
3588     if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3589         == FAILURE)
3590       return MATCH_ERROR;
3591
3592   return found_match;
3593 }
3594
3595
3596 /* Match a function declaration.  */
3597
3598 match
3599 gfc_match_function_decl (void)
3600 {
3601   char name[GFC_MAX_SYMBOL_LEN + 1];
3602   gfc_symbol *sym, *result;
3603   locus old_loc;
3604   match m;
3605   match suffix_match;
3606   match found_match; /* Status returned by match func.  */
3607
3608   if (gfc_current_state () != COMP_NONE
3609       && gfc_current_state () != COMP_INTERFACE
3610       && gfc_current_state () != COMP_CONTAINS)
3611     return MATCH_NO;
3612
3613   gfc_clear_ts (&current_ts);
3614
3615   old_loc = gfc_current_locus;
3616
3617   m = match_prefix (&current_ts);
3618   if (m != MATCH_YES)
3619     {
3620       gfc_current_locus = old_loc;
3621       return m;
3622     }
3623
3624   if (gfc_match ("function% %n", name) != MATCH_YES)
3625     {
3626       gfc_current_locus = old_loc;
3627       return MATCH_NO;
3628     }
3629   if (get_proc_name (name, &sym, false))
3630     return MATCH_ERROR;
3631   gfc_new_block = sym;
3632
3633   m = gfc_match_formal_arglist (sym, 0, 0);
3634   if (m == MATCH_NO)
3635     {
3636       gfc_error ("Expected formal argument list in function "
3637                  "definition at %C");
3638       m = MATCH_ERROR;
3639       goto cleanup;
3640     }
3641   else if (m == MATCH_ERROR)
3642     goto cleanup;
3643
3644   result = NULL;
3645
3646   /* According to the draft, the bind(c) and result clause can
3647      come in either order after the formal_arg_list (i.e., either
3648      can be first, both can exist together or by themselves or neither
3649      one).  Therefore, the match_result can't match the end of the
3650      string, and check for the bind(c) or result clause in either order.  */
3651   found_match = gfc_match_eos ();
3652
3653   /* Make sure that it isn't already declared as BIND(C).  If it is, it
3654      must have been marked BIND(C) with a BIND(C) attribute and that is
3655      not allowed for procedures.  */
3656   if (sym->attr.is_bind_c == 1)
3657     {
3658       sym->attr.is_bind_c = 0;
3659       if (sym->old_symbol != NULL)
3660         gfc_error_now ("BIND(C) attribute at %L can only be used for "
3661                        "variables or common blocks",
3662                        &(sym->old_symbol->declared_at));
3663       else
3664         gfc_error_now ("BIND(C) attribute at %L can only be used for "
3665                        "variables or common blocks", &gfc_current_locus);
3666     }
3667
3668   if (found_match != MATCH_YES)
3669     {
3670       /* If we haven't found the end-of-statement, look for a suffix.  */
3671       suffix_match = gfc_match_suffix (sym, &result);
3672       if (suffix_match == MATCH_YES)
3673         /* Need to get the eos now.  */
3674         found_match = gfc_match_eos ();
3675       else
3676         found_match = suffix_match;
3677     }
3678
3679   if(found_match != MATCH_YES)
3680     m = MATCH_ERROR;
3681   else
3682     {
3683       /* Make changes to the symbol.  */
3684       m = MATCH_ERROR;
3685
3686       if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
3687         goto cleanup;
3688
3689       if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
3690           || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3691         goto cleanup;
3692
3693       if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
3694           && !sym->attr.implicit_type)
3695         {
3696           gfc_error ("Function '%s' at %C already has a type of %s", name,
3697                      gfc_basic_typename (sym->ts.type));
3698           goto cleanup;
3699         }
3700
3701       if (result == NULL)
3702         {
3703           sym->ts = current_ts;
3704           sym->result = sym;
3705         }
3706       else
3707         {
3708           result->ts = current_ts;
3709           sym->result = result;
3710         }
3711
3712       return MATCH_YES;
3713     }
3714
3715 cleanup:
3716   gfc_current_locus = old_loc;
3717   return m;
3718 }
3719
3720
3721 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
3722    pass the name of the entry, rather than the gfc_current_block name, and
3723    to return false upon finding an existing global entry.  */
3724
3725 static bool
3726 add_global_entry (const char *name, int sub)
3727 {
3728   gfc_gsymbol *s;
3729
3730   s = gfc_get_gsymbol(name);
3731
3732   if (s->defined
3733       || (s->type != GSYM_UNKNOWN
3734           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3735     global_used(s, NULL);
3736   else
3737     {
3738       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3739       s->where = gfc_current_locus;
3740       s->defined = 1;
3741       return true;
3742     }
3743   return false;
3744 }
3745
3746
3747 /* Match an ENTRY statement.  */
3748
3749 match
3750 gfc_match_entry (void)
3751 {
3752   gfc_symbol *proc;
3753   gfc_symbol *result;
3754   gfc_symbol *entry;
3755   char name[GFC_MAX_SYMBOL_LEN + 1];
3756   gfc_compile_state state;
3757   match m;
3758   gfc_entry_list *el;
3759   locus old_loc;
3760   bool module_procedure;
3761
3762   m = gfc_match_name (name);
3763   if (m != MATCH_YES)
3764     return m;
3765
3766   state = gfc_current_state ();
3767   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
3768     {
3769       switch (state)
3770         {
3771           case COMP_PROGRAM:
3772             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
3773             break;
3774           case COMP_MODULE:
3775             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
3776             break;
3777           case COMP_BLOCK_DATA:
3778             gfc_error ("ENTRY statement at %C cannot appear within "
3779                        "a BLOCK DATA");
3780             break;
3781           case COMP_INTERFACE:
3782             gfc_error ("ENTRY statement at %C cannot appear within "
3783                        "an INTERFACE");
3784             break;
3785           case COMP_DERIVED:
3786             gfc_error ("ENTRY statement at %C cannot appear within "
3787                        "a DERIVED TYPE block");
3788             break;
3789           case COMP_IF:
3790             gfc_error ("ENTRY statement at %C cannot appear within "
3791                        "an IF-THEN block");
3792             break;
3793           case COMP_DO:
3794             gfc_error ("ENTRY statement at %C cannot appear within "
3795                        "a DO block");
3796             break;
3797           case COMP_SELECT:
3798             gfc_error ("ENTRY statement at %C cannot appear within "
3799                        "a SELECT block");
3800             break;
3801           case COMP_FORALL:
3802             gfc_error ("ENTRY statement at %C cannot appear within "
3803                        "a FORALL block");
3804             break;
3805           case COMP_WHERE:
3806             gfc_error ("ENTRY statement at %C cannot appear within "
3807                        "a WHERE block");
3808             break;
3809           case COMP_CONTAINS:
3810             gfc_error ("ENTRY statement at %C cannot appear within "
3811                        "a contained subprogram");
3812             break;
3813           default:
3814             gfc_internal_error ("gfc_match_entry(): Bad state");
3815         }
3816       return MATCH_ERROR;
3817     }
3818
3819   module_procedure = gfc_current_ns->parent != NULL
3820                    && gfc_current_ns->parent->proc_name
3821                    && gfc_current_ns->parent->proc_name->attr.flavor
3822                       == FL_MODULE;
3823
3824   if (gfc_current_ns->parent != NULL
3825       && gfc_current_ns->parent->proc_name
3826       && !module_procedure)
3827     {
3828       gfc_error("ENTRY statement at %C cannot appear in a "
3829                 "contained procedure");
3830       return MATCH_ERROR;
3831     }
3832
3833   /* Module function entries need special care in get_proc_name
3834      because previous references within the function will have
3835      created symbols attached to the current namespace.  */
3836   if (get_proc_name (name, &entry,
3837                      gfc_current_ns->parent != NULL
3838                      && module_procedure
3839                      && gfc_current_ns->proc_name->attr.function))
3840     return MATCH_ERROR;
3841
3842   proc = gfc_current_block ();
3843
3844   if (state == COMP_SUBROUTINE)
3845     {
3846       /* An entry in a subroutine.  */
3847       if (!add_global_entry (name, 1))
3848         return MATCH_ERROR;
3849
3850       m = gfc_match_formal_arglist (entry, 0, 1);
3851       if (m != MATCH_YES)
3852         return MATCH_ERROR;
3853
3854       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3855           || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
3856         return MATCH_ERROR;
3857     }
3858   else
3859     {
3860       /* An entry in a function.
3861          We need to take special care because writing
3862             ENTRY f()
3863          as
3864             ENTRY f
3865          is allowed, whereas
3866             ENTRY f() RESULT (r)
3867          can't be written as
3868             ENTRY f RESULT (r).  */
3869       if (!add_global_entry (name, 0))
3870         return MATCH_ERROR;
3871
3872       old_loc = gfc_current_locus;
3873       if (gfc_match_eos () == MATCH_YES)
3874         {
3875           gfc_current_locus = old_loc;
3876           /* Match the empty argument list, and add the interface to
3877              the symbol.  */
3878           m = gfc_match_formal_arglist (entry, 0, 1);
3879         }
3880       else
3881         m = gfc_match_formal_arglist (entry, 0, 0);
3882
3883       if (m != MATCH_YES)
3884         return MATCH_ERROR;
3885
3886       result = NULL;
3887
3888       if (gfc_match_eos () == MATCH_YES)
3889         {
3890           if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3891               || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3892             return MATCH_ERROR;
3893
3894           entry->result = entry;
3895         }
3896       else
3897         {
3898           m = match_result (proc, &result);
3899           if (m == MATCH_NO)
3900             gfc_syntax_error (ST_ENTRY);
3901           if (m != MATCH_YES)
3902             return MATCH_ERROR;
3903
3904           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3905               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3906               || gfc_add_function (&entry->attr, result->name, NULL)
3907                  == FAILURE)
3908             return MATCH_ERROR;
3909
3910           entry->result = result;
3911         }
3912     }
3913
3914   if (gfc_match_eos () != MATCH_YES)
3915     {
3916       gfc_syntax_error (ST_ENTRY);
3917       return MATCH_ERROR;
3918     }
3919
3920   entry->attr.recursive = proc->attr.recursive;
3921   entry->attr.elemental = proc->attr.elemental;
3922   entry->attr.pure = proc->attr.pure;
3923
3924   el = gfc_get_entry_list ();
3925   el->sym = entry;
3926   el->next = gfc_current_ns->entries;
3927   gfc_current_ns->entries = el;
3928   if (el->next)
3929     el->id = el->next->id + 1;
3930   else
3931     el->id = 1;
3932
3933   new_st.op = EXEC_ENTRY;
3934   new_st.ext.entry = el;
3935
3936   return MATCH_YES;
3937 }
3938
3939
3940 /* Match a subroutine statement, including optional prefixes.  */
3941
3942 match
3943 gfc_match_subroutine (void)
3944 {
3945   char name[GFC_MAX_SYMBOL_LEN + 1];
3946   gfc_symbol *sym;
3947   match m;
3948   match is_bind_c;
3949   char peek_char;
3950
3951   if (gfc_current_state () != COMP_NONE
3952       && gfc_current_state () != COMP_INTERFACE
3953       && gfc_current_state () != COMP_CONTAINS)
3954     return MATCH_NO;
3955
3956   m = match_prefix (NULL);
3957   if (m != MATCH_YES)
3958     return m;
3959
3960   m = gfc_match ("subroutine% %n", name);
3961   if (m != MATCH_YES)
3962     return m;
3963
3964   if (get_proc_name (name, &sym, false))
3965     return MATCH_ERROR;
3966   gfc_new_block = sym;
3967
3968   /* Check what next non-whitespace character is so we can tell if there
3969      where the required parens if we have a BIND(C).  */
3970   gfc_gobble_whitespace ();
3971   peek_char = gfc_peek_char ();
3972
3973   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3974     return MATCH_ERROR;
3975
3976   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3977     return MATCH_ERROR;
3978
3979   /* Make sure that it isn't already declared as BIND(C).  If it is, it
3980      must have been marked BIND(C) with a BIND(C) attribute and that is
3981      not allowed for procedures.  */
3982   if (sym->attr.is_bind_c == 1)
3983     {
3984       sym->attr.is_bind_c = 0;
3985       if (sym->old_symbol != NULL)
3986         gfc_error_now ("BIND(C) attribute at %L can only be used for "
3987                        "variables or common blocks",
3988                        &(sym->old_symbol->declared_at));
3989       else
3990         gfc_error_now ("BIND(C) attribute at %L can only be used for "
3991                        "variables or common blocks", &gfc_current_locus);
3992     }
3993
3994   /* Here, we are just checking if it has the bind(c) attribute, and if
3995      so, then we need to make sure it's all correct.  If it doesn't,
3996      we still need to continue matching the rest of the subroutine line.  */
3997   is_bind_c = gfc_match_bind_c (sym);
3998   if (is_bind_c == MATCH_ERROR)
3999     {
4000       /* There was an attempt at the bind(c), but it was wrong.  An
4001          error message should have been printed w/in the gfc_match_bind_c
4002          so here we'll just return the MATCH_ERROR.  */
4003       return MATCH_ERROR;
4004     }
4005
4006   if (is_bind_c == MATCH_YES)
4007     {
4008       if (peek_char != '(')
4009         {
4010           gfc_error ("Missing required parentheses before BIND(C) at %C");
4011           return MATCH_ERROR;
4012         }
4013       if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4014           == FAILURE)
4015         return MATCH_ERROR;
4016     }
4017
4018   if (gfc_match_eos () != MATCH_YES)
4019     {
4020       gfc_syntax_error (ST_SUBROUTINE);
4021       return MATCH_ERROR;
4022     }
4023
4024   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4025     return MATCH_ERROR;
4026
4027   return MATCH_YES;
4028 }
4029
4030
4031 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4032    given, and set the binding label in either the given symbol (if not
4033    NULL), or in the current_ts.  The symbol may be NULL because we may
4034    encounter the BIND(C) before the declaration itself.  Return
4035    MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4036    MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4037    or MATCH_YES if the specifier was correct and the binding label and
4038    bind(c) fields were set correctly for the given symbol or the
4039    current_ts.  */
4040
4041 match
4042 gfc_match_bind_c (gfc_symbol *sym)
4043 {
4044   /* binding label, if exists */
4045   char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4046   match double_quote;
4047   match single_quote;
4048   int has_name_equals = 0;
4049
4050   /* Initialize the flag that specifies whether we encountered a NAME=
4051      specifier or not.  */
4052   has_name_equals = 0;
4053
4054   /* Init the first char to nil so we can catch if we don't have
4055      the label (name attr) or the symbol name yet.  */
4056   binding_label[0] = '\0';
4057
4058   /* This much we have to be able to match, in this order, if
4059      there is a bind(c) label.  */
4060   if (gfc_match (" bind ( c ") != MATCH_YES)
4061     return MATCH_NO;
4062
4063   /* Now see if there is a binding label, or if we've reached the
4064      end of the bind(c) attribute without one.  */
4065   if (gfc_match_char (',') == MATCH_YES)
4066     {
4067       if (gfc_match (" name = ") != MATCH_YES)
4068         {
4069           gfc_error ("Syntax error in NAME= specifier for binding label "
4070                      "at %C");
4071           /* should give an error message here */
4072           return MATCH_ERROR;
4073         }
4074
4075       has_name_equals = 1;
4076
4077       /* Get the opening quote.  */
4078       double_quote = MATCH_YES;
4079       single_quote = MATCH_YES;
4080       double_quote = gfc_match_char ('"');
4081       if (double_quote != MATCH_YES)
4082         single_quote = gfc_match_char ('\'');
4083       if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4084         {
4085           gfc_error ("Syntax error in NAME= specifier for binding label "
4086                      "at %C");
4087           return MATCH_ERROR;
4088         }
4089
4090       /* Grab the binding label, using functions that will not lower
4091          case the names automatically.  */
4092       if (gfc_match_name_C (binding_label) != MATCH_YES)
4093          return MATCH_ERROR;
4094
4095       /* Get the closing quotation.  */
4096       if (double_quote == MATCH_YES)
4097         {
4098           if (gfc_match_char ('"') != MATCH_YES)
4099             {
4100               gfc_error ("Missing closing quote '\"' for binding label at %C");
4101               /* User started string with '"' so looked to match it.  */
4102               return MATCH_ERROR;
4103             }
4104         }
4105       else
4106         {
4107           if (gfc_match_char ('\'') != MATCH_YES)
4108             {
4109               gfc_error ("Missing closing quote '\'' for binding label at %C");
4110               /* User started string with "'" char.  */
4111               return MATCH_ERROR;
4112             }
4113         }
4114    }
4115
4116   /* Get the required right paren.  */
4117   if (gfc_match_char (')') != MATCH_YES)
4118     {
4119       gfc_error ("Missing closing paren for binding label at %C");
4120       return MATCH_ERROR;
4121     }
4122
4123   /* Save the binding label to the symbol.  If sym is null, we're
4124      probably matching the typespec attributes of a declaration and
4125      haven't gotten the name yet, and therefore, no symbol yet.  */
4126   if (binding_label[0] != '\0')
4127     {
4128       if (sym != NULL)
4129       {
4130         strncpy (sym->binding_label, binding_label,
4131                  strlen (binding_label)+1);
4132       }
4133       else
4134         strncpy (curr_binding_label, binding_label,
4135                  strlen (binding_label) + 1);
4136     }
4137   else
4138     {
4139       /* No binding label, but if symbol isn't null, we
4140          can set the label for it here.  */
4141       /* TODO: If the name= was given and no binding label (name=""), we simply
4142          will let fortran mangle the symbol name as it usually would.
4143          However, this could still let C call it if the user looked up the
4144          symbol in the object file.  Should the name set during mangling in
4145          trans-decl.c be marked with characters that are invalid for C to
4146          prevent this?  */
4147       if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4148         strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4149     }
4150
4151   return MATCH_YES;
4152 }
4153
4154
4155 /* Return nonzero if we're currently compiling a contained procedure.  */
4156
4157 static int
4158 contained_procedure (void)
4159 {
4160   gfc_state_data *s;
4161
4162   for (s=gfc_state_stack; s; s=s->previous)
4163     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4164         && s->previous != NULL && s->previous->state == COMP_CONTAINS)
4165       return 1;
4166
4167   return 0;
4168 }
4169
4170 /* Set the kind of each enumerator.  The kind is selected such that it is
4171    interoperable with the corresponding C enumeration type, making
4172    sure that -fshort-enums is honored.  */
4173
4174 static void
4175 set_enum_kind(void)
4176 {
4177   enumerator_history *current_history = NULL;
4178   int kind;
4179   int i;
4180
4181   if (max_enum == NULL || enum_history == NULL)
4182     return;
4183
4184   if (!gfc_option.fshort_enums)
4185     return;
4186
4187   i = 0;
4188   do
4189     {
4190       kind = gfc_integer_kinds[i++].kind;
4191     }
4192   while (kind < gfc_c_int_kind
4193          && gfc_check_integer_range (max_enum->initializer->value.integer,
4194                                      kind) != ARITH_OK);
4195
4196   current_history = enum_history;
4197   while (current_history != NULL)
4198     {
4199       current_history->sym->ts.kind = kind;