gcc/fortran/decl.c

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