gcc/fortran/decl.c

   1 /* Declaration statement matcher
   2    Copyright (C) 2002, 2004, 2005 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 /* gfc_new_block points to the symbol of a newly matched block.  */
  47
  48 gfc_symbol *gfc_new_block;
  49
  50
  51 /********************* DATA statement subroutines *********************/
  52
  53 /* Free a gfc_data_variable structure and everything beneath it.  */
  54
  55 static void
  56 free_variable (gfc_data_variable * p)
  57 {
  58   gfc_data_variable *q;
  59
  60   for (; p; p = q)
  61     {
  62       q = p->next;
  63       gfc_free_expr (p->expr);
  64       gfc_free_iterator (&p->iter, 0);
  65       free_variable (p->list);
  66
  67       gfc_free (p);
  68     }
  69 }
  70
  71
  72 /* Free a gfc_data_value structure and everything beneath it.  */
  73
  74 static void
  75 free_value (gfc_data_value * p)
  76 {
  77   gfc_data_value *q;
  78
  79   for (; p; p = q)
  80     {
  81       q = p->next;
  82       gfc_free_expr (p->expr);
  83       gfc_free (p);
  84     }
  85 }
  86
  87
  88 /* Free a list of gfc_data structures.  */
  89
  90 void
  91 gfc_free_data (gfc_data * p)
  92 {
  93   gfc_data *q;
  94
  95   for (; p; p = q)
  96     {
  97       q = p->next;
  98
  99       free_variable (p->var);
 100       free_value (p->value);
 101
 102       gfc_free (p);
 103     }
 104 }
 105
 106
 107 static match var_element (gfc_data_variable *);
 108
 109 /* Match a list of variables terminated by an iterator and a right
 110    parenthesis.  */
 111
 112 static match
 113 var_list (gfc_data_variable * parent)
 114 {
 115   gfc_data_variable *tail, var;
 116   match m;
 117
 118   m = var_element (&var);
 119   if (m == MATCH_ERROR)
 120     return MATCH_ERROR;
 121   if (m == MATCH_NO)
 122     goto syntax;
 123
 124   tail = gfc_get_data_variable ();
 125   *tail = var;
 126
 127   parent->list = tail;
 128
 129   for (;;)
 130     {
 131       if (gfc_match_char (',') != MATCH_YES)
 132         goto syntax;
 133
 134       m = gfc_match_iterator (&parent->iter, 1);
 135       if (m == MATCH_YES)
 136         break;
 137       if (m == MATCH_ERROR)
 138         return MATCH_ERROR;
 139
 140       m = var_element (&var);
 141       if (m == MATCH_ERROR)
 142         return MATCH_ERROR;
 143       if (m == MATCH_NO)
 144         goto syntax;
 145
 146       tail->next = gfc_get_data_variable ();
 147       tail = tail->next;
 148
 149       *tail = var;
 150     }
 151
 152   if (gfc_match_char (')') != MATCH_YES)
 153     goto syntax;
 154   return MATCH_YES;
 155
 156 syntax:
 157   gfc_syntax_error (ST_DATA);
 158   return MATCH_ERROR;
 159 }
 160
 161
 162 /* Match a single element in a data variable list, which can be a
 163    variable-iterator list.  */
 164
 165 static match
 166 var_element (gfc_data_variable * new)
 167 {
 168   match m;
 169   gfc_symbol *sym;
 170
 171   memset (new, 0, sizeof (gfc_data_variable));
 172
 173   if (gfc_match_char ('(') == MATCH_YES)
 174     return var_list (new);
 175
 176   m = gfc_match_variable (&new->expr, 0);
 177   if (m != MATCH_YES)
 178     return m;
 179
 180   sym = new->expr->symtree->n.sym;
 181
 182   if(sym->value != NULL)
 183     {
 184       gfc_error ("Variable '%s' at %C already has an initialization",
 185                  sym->name);
 186       return MATCH_ERROR;
 187     }
 188
 189 #if 0 /* TODO: Find out where to move this message */
 190   if (sym->attr.in_common)
 191     /* See if sym is in the blank common block.  */
 192     for (t = &sym->ns->blank_common; t; t = t->common_next)
 193       if (sym == t->head)
 194         {
 195           gfc_error ("DATA statement at %C may not initialize variable "
 196                      "'%s' from blank COMMON", sym->name);
 197           return MATCH_ERROR;
 198         }
 199 #endif
 200
 201   if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
 202     return MATCH_ERROR;
 203
 204   return MATCH_YES;
 205 }
 206
 207
 208 /* Match the top-level list of data variables.  */
 209
 210 static match
 211 top_var_list (gfc_data * d)
 212 {
 213   gfc_data_variable var, *tail, *new;
 214   match m;
 215
 216   tail = NULL;
 217
 218   for (;;)
 219     {
 220       m = var_element (&var);
 221       if (m == MATCH_NO)
 222         goto syntax;
 223       if (m == MATCH_ERROR)
 224         return MATCH_ERROR;
 225
 226       new = gfc_get_data_variable ();
 227       *new = var;
 228
 229       if (tail == NULL)
 230         d->var = new;
 231       else
 232         tail->next = new;
 233
 234       tail = new;
 235
 236       if (gfc_match_char ('/') == MATCH_YES)
 237         break;
 238       if (gfc_match_char (',') != MATCH_YES)
 239         goto syntax;
 240     }
 241
 242   return MATCH_YES;
 243
 244 syntax:
 245   gfc_syntax_error (ST_DATA);
 246   return MATCH_ERROR;
 247 }
 248
 249
 250 static match
 251 match_data_constant (gfc_expr ** result)
 252 {
 253   char name[GFC_MAX_SYMBOL_LEN + 1];
 254   gfc_symbol *sym;
 255   gfc_expr *expr;
 256   match m;
 257
 258   m = gfc_match_literal_constant (&expr, 1);
 259   if (m == MATCH_YES)
 260     {
 261       *result = expr;
 262       return MATCH_YES;
 263     }
 264
 265   if (m == MATCH_ERROR)
 266     return MATCH_ERROR;
 267
 268   m = gfc_match_null (result);
 269   if (m != MATCH_NO)
 270     return m;
 271
 272   m = gfc_match_name (name);
 273   if (m != MATCH_YES)
 274     return m;
 275
 276   if (gfc_find_symbol (name, NULL, 1, &sym))
 277     return MATCH_ERROR;
 278
 279   if (sym == NULL
 280       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
 281     {
 282       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
 283                  name);
 284       return MATCH_ERROR;
 285     }
 286   else if (sym->attr.flavor == FL_DERIVED)
 287     return gfc_match_structure_constructor (sym, result);
 288
 289   *result = gfc_copy_expr (sym->value);
 290   return MATCH_YES;
 291 }
 292
 293
 294 /* Match a list of values in a DATA statement.  The leading '/' has
 295    already been seen at this point.  */
 296
 297 static match
 298 top_val_list (gfc_data * data)
 299 {
 300   gfc_data_value *new, *tail;
 301   gfc_expr *expr;
 302   const char *msg;
 303   match m;
 304
 305   tail = NULL;
 306
 307   for (;;)
 308     {
 309       m = match_data_constant (&expr);
 310       if (m == MATCH_NO)
 311         goto syntax;
 312       if (m == MATCH_ERROR)
 313         return MATCH_ERROR;
 314
 315       new = gfc_get_data_value ();
 316
 317       if (tail == NULL)
 318         data->value = new;
 319       else
 320         tail->next = new;
 321
 322       tail = new;
 323
 324       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
 325         {
 326           tail->expr = expr;
 327           tail->repeat = 1;
 328         }
 329       else
 330         {
 331           signed int tmp;
 332           msg = gfc_extract_int (expr, &tmp);
 333           gfc_free_expr (expr);
 334           if (msg != NULL)
 335             {
 336               gfc_error (msg);
 337               return MATCH_ERROR;
 338             }
 339           tail->repeat = tmp;
 340
 341           m = match_data_constant (&tail->expr);
 342           if (m == MATCH_NO)
 343             goto syntax;
 344           if (m == MATCH_ERROR)
 345             return MATCH_ERROR;
 346         }
 347
 348       if (gfc_match_char ('/') == MATCH_YES)
 349         break;
 350       if (gfc_match_char (',') == MATCH_NO)
 351         goto syntax;
 352     }
 353
 354   return MATCH_YES;
 355
 356 syntax:
 357   gfc_syntax_error (ST_DATA);
 358   return MATCH_ERROR;
 359 }
 360
 361
 362 /* Matches an old style initialization.  */
 363
 364 static match
 365 match_old_style_init (const char *name)
 366 {
 367   match m;
 368   gfc_symtree *st;
 369   gfc_data *newdata;
 370
 371   /* Set up data structure to hold initializers.  */
 372   gfc_find_sym_tree (name, NULL, 0, &st);
 373
 374   newdata = gfc_get_data ();
 375   newdata->var = gfc_get_data_variable ();
 376   newdata->var->expr = gfc_get_variable_expr (st);
 377
 378   /* Match initial value list. This also eats the terminal
 379      '/'.  */
 380   m = top_val_list (newdata);
 381   if (m != MATCH_YES)
 382     {
 383       gfc_free (newdata);
 384       return m;
 385     }
 386
 387   if (gfc_pure (NULL))
 388     {
 389       gfc_error ("Initialization at %C is not allowed in a PURE procedure");
 390       gfc_free (newdata);
 391       return MATCH_ERROR;
 392     }
 393
 394   /* Chain in namespace list of DATA initializers.  */
 395   newdata->next = gfc_current_ns->data;
 396   gfc_current_ns->data = newdata;
 397
 398   return m;
 399 }
 400
 401 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
 402    we are matching a DATA statement and are therefore issuing an error
 403    if we encounter something unexpected, if not, we're trying to match
 404    an old-style initialization expression of the form INTEGER I /2/.  */
 405
 406 match
 407 gfc_match_data (void)
 408 {
 409   gfc_data *new;
 410   match m;
 411
 412   for (;;)
 413     {
 414       new = gfc_get_data ();
 415       new->where = gfc_current_locus;
 416
 417       m = top_var_list (new);
 418       if (m != MATCH_YES)
 419         goto cleanup;
 420
 421       m = top_val_list (new);
 422       if (m != MATCH_YES)
 423         goto cleanup;
 424
 425       new->next = gfc_current_ns->data;
 426       gfc_current_ns->data = new;
 427
 428       if (gfc_match_eos () == MATCH_YES)
 429         break;
 430
 431       gfc_match_char (',');     /* Optional comma */
 432     }
 433
 434   if (gfc_pure (NULL))
 435     {
 436       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
 437       return MATCH_ERROR;
 438     }
 439
 440   return MATCH_YES;
 441
 442 cleanup:
 443   gfc_free_data (new);
 444   return MATCH_ERROR;
 445 }
 446
 447
 448 /************************ Declaration statements *********************/
 449
 450 /* Match an intent specification.  Since this can only happen after an
 451    INTENT word, a legal intent-spec must follow.  */
 452
 453 static sym_intent
 454 match_intent_spec (void)
 455 {
 456
 457   if (gfc_match (" ( in out )") == MATCH_YES)
 458     return INTENT_INOUT;
 459   if (gfc_match (" ( in )") == MATCH_YES)
 460     return INTENT_IN;
 461   if (gfc_match (" ( out )") == MATCH_YES)
 462     return INTENT_OUT;
 463
 464   gfc_error ("Bad INTENT specification at %C");
 465   return INTENT_UNKNOWN;
 466 }
 467
 468
 469 /* Matches a character length specification, which is either a
 470    specification expression or a '*'.  */
 471
 472 static match
 473 char_len_param_value (gfc_expr ** expr)
 474 {
 475
 476   if (gfc_match_char ('*') == MATCH_YES)
 477     {
 478       *expr = NULL;
 479       return MATCH_YES;
 480     }
 481
 482   return gfc_match_expr (expr);
 483 }
 484
 485
 486 /* A character length is a '*' followed by a literal integer or a
 487    char_len_param_value in parenthesis.  */
 488
 489 static match
 490 match_char_length (gfc_expr ** expr)
 491 {
 492   int length;
 493   match m;
 494
 495   m = gfc_match_char ('*');
 496   if (m != MATCH_YES)
 497     return m;
 498
 499   m = gfc_match_small_literal_int (&length);
 500   if (m == MATCH_ERROR)
 501     return m;
 502
 503   if (m == MATCH_YES)
 504     {
 505       *expr = gfc_int_expr (length);
 506       return m;
 507     }
 508
 509   if (gfc_match_char ('(') == MATCH_NO)
 510     goto syntax;
 511
 512   m = char_len_param_value (expr);
 513   if (m == MATCH_ERROR)
 514     return m;
 515   if (m == MATCH_NO)
 516     goto syntax;
 517
 518   if (gfc_match_char (')') == MATCH_NO)
 519     {
 520       gfc_free_expr (*expr);
 521       *expr = NULL;
 522       goto syntax;
 523     }
 524
 525   return MATCH_YES;
 526
 527 syntax:
 528   gfc_error ("Syntax error in character length specification at %C");
 529   return MATCH_ERROR;
 530 }
 531
 532
 533 /* Special subroutine for finding a symbol.  Check if the name is found
 534    in the current name space.  If not, and we're compiling a function or
 535    subroutine and the parent compilation unit is an interface, then check
 536    to see if the name we've been given is the name of the interface
 537    (located in another namespace).  */
 538
 539 static int
 540 find_special (const char *name, gfc_symbol ** result)
 541 {
 542   gfc_state_data *s;
 543   int i;
 544
 545   i = gfc_get_symbol (name, NULL, result);
 546   if (i==0)
 547     goto end;
 548
 549   if (gfc_current_state () != COMP_SUBROUTINE
 550       && gfc_current_state () != COMP_FUNCTION)
 551     goto end;
 552
 553   s = gfc_state_stack->previous;
 554   if (s == NULL)
 555     goto end;
 556
 557   if (s->state != COMP_INTERFACE)
 558     goto end;
 559   if (s->sym == NULL)
 560     goto end;                  /* Nameless interface */
 561
 562   if (strcmp (name, s->sym->name) == 0)
 563     {
 564       *result = s->sym;
 565       return 0;
 566     }
 567
 568 end:
 569   return i;
 570 }
 571
 572
 573 /* Special subroutine for getting a symbol node associated with a
 574    procedure name, used in SUBROUTINE and FUNCTION statements.  The
 575    symbol is created in the parent using with symtree node in the
 576    child unit pointing to the symbol.  If the current namespace has no
 577    parent, then the symbol is just created in the current unit.  */
 578
 579 static int
 580 get_proc_name (const char *name, gfc_symbol ** result)
 581 {
 582   gfc_symtree *st;
 583   gfc_symbol *sym;
 584   int rc;
 585
 586   if (gfc_current_ns->parent == NULL)
 587     return gfc_get_symbol (name, NULL, result);
 588
 589   rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
 590   if (*result == NULL)
 591     return rc;
 592
 593   /* ??? Deal with ENTRY problem */
 594
 595   st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 596
 597   sym = *result;
 598   st->n.sym = sym;
 599   sym->refs++;
 600
 601   /* See if the procedure should be a module procedure */
 602
 603   if (sym->ns->proc_name != NULL
 604       && sym->ns->proc_name->attr.flavor == FL_MODULE
 605       && sym->attr.proc != PROC_MODULE
 606       && gfc_add_procedure (&sym->attr, PROC_MODULE,
 607                             sym->name, NULL) == FAILURE)
 608     rc = 2;
 609
 610   return rc;
 611 }
 612
 613
 614 /* Function called by variable_decl() that adds a name to the symbol
 615    table.  */
 616
 617 static try
 618 build_sym (const char *name, gfc_charlen * cl,
 619            gfc_array_spec ** as, locus * var_locus)
 620 {
 621   symbol_attribute attr;
 622   gfc_symbol *sym;
 623
 624   /* if (find_special (name, &sym)) */
 625   if (gfc_get_symbol (name, NULL, &sym))
 626     return FAILURE;
 627
 628   /* Start updating the symbol table.  Add basic type attribute
 629      if present.  */
 630   if (current_ts.type != BT_UNKNOWN
 631       &&(sym->attr.implicit_type == 0
 632          || !gfc_compare_types (&sym->ts, &current_ts))
 633       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
 634     return FAILURE;
 635
 636   if (sym->ts.type == BT_CHARACTER)
 637     sym->ts.cl = cl;
 638
 639   /* Add dimension attribute if present.  */
 640   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
 641     return FAILURE;
 642   *as = NULL;
 643
 644   /* Add attribute to symbol.  The copy is so that we can reset the
 645      dimension attribute.  */
 646   attr = current_attr;
 647   attr.dimension = 0;
 648
 649   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
 650     return FAILURE;
 651
 652   return SUCCESS;
 653 }
 654
 655 /* Set character constant to the given length. The constant will be padded or
 656    truncated.  */
 657
 658 void
 659 gfc_set_constant_character_len (int len, gfc_expr * expr)
 660 {
 661   char * s;
 662   int slen;
 663
 664   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 665   gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
 666
 667   slen = expr->value.character.length;
 668   if (len != slen)
 669     {
 670       s = gfc_getmem (len);
 671       memcpy (s, expr->value.character.string, MIN (len, slen));
 672       if (len > slen)
 673         memset (&s[slen], ' ', len - slen);
 674       gfc_free (expr->value.character.string);
 675       expr->value.character.string = s;
 676       expr->value.character.length = len;
 677     }
 678 }
 679
 680 /* Function called by variable_decl() that adds an initialization
 681    expression to a symbol.  */
 682
 683 static try
 684 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
 685                       locus * var_locus)
 686 {
 687   symbol_attribute attr;
 688   gfc_symbol *sym;
 689   gfc_expr *init;
 690
 691   init = *initp;
 692   if (find_special (name, &sym))
 693     return FAILURE;
 694
 695   attr = sym->attr;
 696
 697   /* If this symbol is confirming an implicit parameter type,
 698      then an initialization expression is not allowed.  */
 699   if (attr.flavor == FL_PARAMETER
 700       && sym->value != NULL
 701       && *initp != NULL)
 702     {
 703       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
 704                  sym->name);
 705       return FAILURE;
 706     }
 707
 708   if (attr.in_common
 709       && !attr.data
 710       && *initp != NULL)
 711     {
 712       gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
 713                  sym->name);
 714       return FAILURE;
 715     }
 716
 717   if (init == NULL)
 718     {
 719       /* An initializer is required for PARAMETER declarations.  */
 720       if (attr.flavor == FL_PARAMETER)
 721         {
 722           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
 723           return FAILURE;
 724         }
 725     }
 726   else
 727     {
 728       /* If a variable appears in a DATA block, it cannot have an
 729          initializer.  */
 730       if (sym->attr.data)
 731         {
 732           gfc_error
 733             ("Variable '%s' at %C with an initializer already appears "
 734              "in a DATA statement", sym->name);
 735           return FAILURE;
 736         }
 737
 738       /* Check if the assignment can happen. This has to be put off
 739          until later for a derived type variable.  */
 740       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
 741           && gfc_check_assign_symbol (sym, init) == FAILURE)
 742         return FAILURE;
 743
 744       if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
 745         {
 746           /* Update symbol character length according initializer.  */
 747           if (sym->ts.cl->length == NULL)
 748             {
 749               /* If there are multiple CHARACTER variables declared on
 750                  the same line, we don't want them to share the same
 751                 length.  */
 752               sym->ts.cl = gfc_get_charlen ();
 753               sym->ts.cl->next = gfc_current_ns->cl_list;
 754               gfc_current_ns->cl_list = sym->ts.cl;
 755
 756               if (init->expr_type == EXPR_CONSTANT)
 757                 sym->ts.cl->length =
 758                         gfc_int_expr (init->value.character.length);
 759               else if (init->expr_type == EXPR_ARRAY)
 760                 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
 761             }
 762           /* Update initializer character length according symbol.  */
 763           else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
 764             {
 765               int len = mpz_get_si (sym->ts.cl->length->value.integer);
 766               gfc_constructor * p;
 767
 768               if (init->expr_type == EXPR_CONSTANT)
 769                 gfc_set_constant_character_len (len, init);
 770               else if (init->expr_type == EXPR_ARRAY)
 771                 {
 772                   gfc_free_expr (init->ts.cl->length);
 773                   init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
 774                   for (p = init->value.constructor; p; p = p->next)
 775                     gfc_set_constant_character_len (len, p->expr);
 776                 }
 777             }
 778         }
 779
 780       /* Add initializer.  Make sure we keep the ranks sane.  */
 781       if (sym->attr.dimension && init->rank == 0)
 782         init->rank = sym->as->rank;
 783
 784       sym->value = init;
 785       *initp = NULL;
 786     }
 787
 788   return SUCCESS;
 789 }
 790
 791
 792 /* Function called by variable_decl() that adds a name to a structure
 793    being built.  */
 794
 795 static try
 796 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
 797               gfc_array_spec ** as)
 798 {
 799   gfc_component *c;
 800
 801   /* If the current symbol is of the same derived type that we're
 802      constructing, it must have the pointer attribute.  */
 803   if (current_ts.type == BT_DERIVED
 804       && current_ts.derived == gfc_current_block ()
 805       && current_attr.pointer == 0)
 806     {
 807       gfc_error ("Component at %C must have the POINTER attribute");
 808       return FAILURE;
 809     }
 810
 811   if (gfc_current_block ()->attr.pointer
 812       && (*as)->rank != 0)
 813     {
 814       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
 815         {
 816           gfc_error ("Array component of structure at %C must have explicit "
 817                      "or deferred shape");
 818           return FAILURE;
 819         }
 820     }
 821
 822   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
 823     return FAILURE;
 824
 825   c->ts = current_ts;
 826   c->ts.cl = cl;
 827   gfc_set_component_attr (c, &current_attr);
 828
 829   c->initializer = *init;
 830   *init = NULL;
 831
 832   c->as = *as;
 833   if (c->as != NULL)
 834     c->dimension = 1;
 835   *as = NULL;
 836
 837   /* Check array components.  */
 838   if (!c->dimension)
 839     return SUCCESS;
 840
 841   if (c->pointer)
 842     {
 843       if (c->as->type != AS_DEFERRED)
 844         {
 845           gfc_error ("Pointer array component of structure at %C "
 846                      "must have a deferred shape");
 847           return FAILURE;
 848         }
 849     }
 850   else
 851     {
 852       if (c->as->type != AS_EXPLICIT)
 853         {
 854           gfc_error
 855             ("Array component of structure at %C must have an explicit "
 856              "shape");
 857           return FAILURE;
 858         }
 859     }
 860
 861   return SUCCESS;
 862 }
 863
 864
 865 /* Match a 'NULL()', and possibly take care of some side effects.  */
 866
 867 match
 868 gfc_match_null (gfc_expr ** result)
 869 {
 870   gfc_symbol *sym;
 871   gfc_expr *e;
 872   match m;
 873
 874   m = gfc_match (" null ( )");
 875   if (m != MATCH_YES)
 876     return m;
 877
 878   /* The NULL symbol now has to be/become an intrinsic function.  */
 879   if (gfc_get_symbol ("null", NULL, &sym))
 880     {
 881       gfc_error ("NULL() initialization at %C is ambiguous");
 882       return MATCH_ERROR;
 883     }
 884
 885   gfc_intrinsic_symbol (sym);
 886
 887   if (sym->attr.proc != PROC_INTRINSIC
 888       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
 889                              sym->name, NULL) == FAILURE
 890           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
 891     return MATCH_ERROR;
 892
 893   e = gfc_get_expr ();
 894   e->where = gfc_current_locus;
 895   e->expr_type = EXPR_NULL;
 896   e->ts.type = BT_UNKNOWN;
 897
 898   *result = e;
 899
 900   return MATCH_YES;
 901 }
 902
 903
 904 /* Match a variable name with an optional initializer.  When this
 905    subroutine is called, a variable is expected to be parsed next.
 906    Depending on what is happening at the moment, updates either the
 907    symbol table or the current interface.  */
 908
 909 static match
 910 variable_decl (int elem)
 911 {
 912   char name[GFC_MAX_SYMBOL_LEN + 1];
 913   gfc_expr *initializer, *char_len;
 914   gfc_array_spec *as;
 915   gfc_charlen *cl;
 916   locus var_locus;
 917   match m;
 918   try t;
 919
 920   initializer = NULL;
 921   as = NULL;
 922
 923   /* When we get here, we've just matched a list of attributes and
 924      maybe a type and a double colon.  The next thing we expect to see
 925      is the name of the symbol.  */
 926   m = gfc_match_name (name);
 927   if (m != MATCH_YES)
 928     goto cleanup;
 929
 930   var_locus = gfc_current_locus;
 931
 932   /* Now we could see the optional array spec. or character length.  */
 933   m = gfc_match_array_spec (&as);
 934   if (m == MATCH_ERROR)
 935     goto cleanup;
 936   if (m == MATCH_NO)
 937     as = gfc_copy_array_spec (current_as);
 938
 939   char_len = NULL;
 940   cl = NULL;
 941
 942   if (current_ts.type == BT_CHARACTER)
 943     {
 944       switch (match_char_length (&char_len))
 945         {
 946         case MATCH_YES:
 947           cl = gfc_get_charlen ();
 948           cl->next = gfc_current_ns->cl_list;
 949           gfc_current_ns->cl_list = cl;
 950
 951           cl->length = char_len;
 952           break;
 953
 954         /* Non-constant lengths need to be copied after the first
 955            element.  */
 956         case MATCH_NO:
 957           if (elem > 1 && current_ts.cl->length
 958                 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
 959             {
 960               cl = gfc_get_charlen ();
 961               cl->next = gfc_current_ns->cl_list;
 962               gfc_current_ns->cl_list = cl;
 963               cl->length = gfc_copy_expr (current_ts.cl->length);
 964             }
 965           else
 966             cl = current_ts.cl;
 967
 968           break;
 969
 970         case MATCH_ERROR:
 971           goto cleanup;
 972         }
 973     }
 974
 975   /* OK, we've successfully matched the declaration.  Now put the
 976      symbol in the current namespace, because it might be used in the
 977      optional initialization expression for this symbol, e.g. this is
 978      perfectly legal:
 979
 980      integer, parameter :: i = huge(i)
 981
 982      This is only true for parameters or variables of a basic type.
 983      For components of derived types, it is not true, so we don't
 984      create a symbol for those yet.  If we fail to create the symbol,
 985      bail out.  */
 986   if (gfc_current_state () != COMP_DERIVED
 987       && build_sym (name, cl, &as, &var_locus) == FAILURE)
 988     {
 989       m = MATCH_ERROR;
 990       goto cleanup;
 991     }
 992
 993   /* In functions that have a RESULT variable defined, the function
 994      name always refers to function calls.  Therefore, the name is
 995      not allowed to appear in specification statements.  */
 996   if (gfc_current_state () == COMP_FUNCTION
 997       && gfc_current_block () != NULL
 998       && gfc_current_block ()->result != NULL
 999       && gfc_current_block ()->result != gfc_current_block ()
1000       && strcmp (gfc_current_block ()->name, name) == 0)
1001     {
1002       gfc_error ("Function name '%s' not allowed at %C", name);
1003       m = MATCH_ERROR;
1004       goto cleanup;
1005     }
1006
1007   /* We allow old-style initializations of the form
1008        integer i /2/, j(4) /3*3, 1/
1009      (if no colon has been seen). These are different from data
1010      statements in that initializers are only allowed to apply to the
1011      variable immediately preceding, i.e.
1012        integer i, j /1, 2/
1013      is not allowed. Therefore we have to do some work manually, that
1014      could otherwise be left to the matchers for DATA statements.  */
1015
1016   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1017     {
1018       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1019                           "initialization at %C") == FAILURE)
1020         return MATCH_ERROR;
1021
1022       return match_old_style_init (name);
1023     }
1024
1025   /* The double colon must be present in order to have initializers.
1026      Otherwise the statement is ambiguous with an assignment statement.  */
1027   if (colon_seen)
1028     {
1029       if (gfc_match (" =>") == MATCH_YES)
1030         {
1031
1032           if (!current_attr.pointer)
1033             {
1034               gfc_error ("Initialization at %C isn't for a pointer variable");
1035               m = MATCH_ERROR;
1036               goto cleanup;
1037             }
1038
1039           m = gfc_match_null (&initializer);
1040           if (m == MATCH_NO)
1041             {
1042               gfc_error ("Pointer initialization requires a NULL at %C");
1043               m = MATCH_ERROR;
1044             }
1045
1046           if (gfc_pure (NULL))
1047             {
1048               gfc_error
1049                 ("Initialization of pointer at %C is not allowed in a "
1050                  "PURE procedure");
1051               m = MATCH_ERROR;
1052             }
1053
1054           if (m != MATCH_YES)
1055             goto cleanup;
1056
1057           initializer->ts = current_ts;
1058
1059         }
1060       else if (gfc_match_char ('=') == MATCH_YES)
1061         {
1062           if (current_attr.pointer)
1063             {
1064               gfc_error
1065                 ("Pointer initialization at %C requires '=>', not '='");
1066               m = MATCH_ERROR;
1067               goto cleanup;
1068             }
1069
1070           m = gfc_match_init_expr (&initializer);
1071           if (m == MATCH_NO)
1072             {
1073               gfc_error ("Expected an initialization expression at %C");
1074               m = MATCH_ERROR;
1075             }
1076
1077           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1078             {
1079               gfc_error
1080                 ("Initialization of variable at %C is not allowed in a "
1081                  "PURE procedure");
1082               m = MATCH_ERROR;
1083             }
1084
1085           if (m != MATCH_YES)
1086             goto cleanup;
1087         }
1088     }
1089
1090   /* Add the initializer.  Note that it is fine if initializer is
1091      NULL here, because we sometimes also need to check if a
1092      declaration *must* have an initialization expression.  */
1093   if (gfc_current_state () != COMP_DERIVED)
1094     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1095   else
1096     {
1097       if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
1098         initializer = gfc_default_initializer (&current_ts);
1099       t = build_struct (name, cl, &initializer, &as);
1100     }
1101
1102   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1103
1104 cleanup:
1105   /* Free stuff up and return.  */
1106   gfc_free_expr (initializer);
1107   gfc_free_array_spec (as);
1108
1109   return m;
1110 }
1111
1112
1113 /* Match an extended-f77 kind specification.  */
1114
1115 match
1116 gfc_match_old_kind_spec (gfc_typespec * ts)
1117 {
1118   match m;
1119
1120   if (gfc_match_char ('*') != MATCH_YES)
1121     return MATCH_NO;
1122
1123   m = gfc_match_small_literal_int (&ts->kind);
1124   if (m != MATCH_YES)
1125     return MATCH_ERROR;
1126
1127   /* Massage the kind numbers for complex types.  */
1128   if (ts->type == BT_COMPLEX && ts->kind == 8)
1129     ts->kind = 4;
1130   if (ts->type == BT_COMPLEX && ts->kind == 16)
1131     ts->kind = 8;
1132
1133   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1134     {
1135       gfc_error ("Old-style kind %d not supported for type %s at %C",
1136                  ts->kind, gfc_basic_typename (ts->type));
1137
1138       return MATCH_ERROR;
1139     }
1140
1141   return MATCH_YES;
1142 }
1143
1144
1145 /* Match a kind specification.  Since kinds are generally optional, we
1146    usually return MATCH_NO if something goes wrong.  If a "kind="
1147    string is found, then we know we have an error.  */
1148
1149 match
1150 gfc_match_kind_spec (gfc_typespec * ts)
1151 {
1152   locus where;
1153   gfc_expr *e;
1154   match m, n;
1155   const char *msg;
1156
1157   m = MATCH_NO;
1158   e = NULL;
1159
1160   where = gfc_current_locus;
1161
1162   if (gfc_match_char ('(') == MATCH_NO)
1163     return MATCH_NO;
1164
1165   /* Also gobbles optional text.  */
1166   if (gfc_match (" kind = ") == MATCH_YES)
1167     m = MATCH_ERROR;
1168
1169   n = gfc_match_init_expr (&e);
1170   if (n == MATCH_NO)
1171     gfc_error ("Expected initialization expression at %C");
1172   if (n != MATCH_YES)
1173     return MATCH_ERROR;
1174
1175   if (e->rank != 0)
1176     {
1177       gfc_error ("Expected scalar initialization expression at %C");
1178       m = MATCH_ERROR;
1179       goto no_match;
1180     }
1181
1182   msg = gfc_extract_int (e, &ts->kind);
1183   if (msg != NULL)
1184     {
1185       gfc_error (msg);
1186       m = MATCH_ERROR;
1187       goto no_match;
1188     }
1189
1190   gfc_free_expr (e);
1191   e = NULL;
1192
1193   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1194     {
1195       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1196                  gfc_basic_typename (ts->type));
1197
1198       m = MATCH_ERROR;
1199       goto no_match;
1200     }
1201
1202   if (gfc_match_char (')') != MATCH_YES)
1203     {
1204       gfc_error ("Missing right paren at %C");
1205       goto no_match;
1206     }
1207
1208   return MATCH_YES;
1209
1210 no_match:
1211   gfc_free_expr (e);
1212   gfc_current_locus = where;
1213   return m;
1214 }
1215
1216
1217 /* Match the various kind/length specifications in a CHARACTER
1218    declaration.  We don't return MATCH_NO.  */
1219
1220 static match
1221 match_char_spec (gfc_typespec * ts)
1222 {
1223   int i, kind, seen_length;
1224   gfc_charlen *cl;
1225   gfc_expr *len;
1226   match m;
1227
1228   kind = gfc_default_character_kind;
1229   len = NULL;
1230   seen_length = 0;
1231
1232   /* Try the old-style specification first.  */
1233   old_char_selector = 0;
1234
1235   m = match_char_length (&len);
1236   if (m != MATCH_NO)
1237     {
1238       if (m == MATCH_YES)
1239         old_char_selector = 1;
1240       seen_length = 1;
1241       goto done;
1242     }
1243
1244   m = gfc_match_char ('(');
1245   if (m != MATCH_YES)
1246     {
1247       m = MATCH_YES;    /* character without length is a single char */
1248       goto done;
1249     }
1250
1251   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] )   */
1252   if (gfc_match (" kind =") == MATCH_YES)
1253     {
1254       m = gfc_match_small_int (&kind);
1255       if (m == MATCH_ERROR)
1256         goto done;
1257       if (m == MATCH_NO)
1258         goto syntax;
1259
1260       if (gfc_match (" , len =") == MATCH_NO)
1261         goto rparen;
1262
1263       m = char_len_param_value (&len);
1264       if (m == MATCH_NO)
1265         goto syntax;
1266       if (m == MATCH_ERROR)
1267         goto done;
1268       seen_length = 1;
1269
1270       goto rparen;
1271     }
1272
1273   /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> )  */
1274   if (gfc_match (" len =") == MATCH_YES)
1275     {
1276       m = char_len_param_value (&len);
1277       if (m == MATCH_NO)
1278         goto syntax;
1279       if (m == MATCH_ERROR)
1280         goto done;
1281       seen_length = 1;
1282
1283       if (gfc_match_char (')') == MATCH_YES)
1284         goto done;
1285
1286       if (gfc_match (" , kind =") != MATCH_YES)
1287         goto syntax;
1288
1289       gfc_match_small_int (&kind);
1290
1291       if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1292         {
1293           gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1294           return MATCH_YES;
1295         }
1296
1297       goto rparen;
1298     }
1299
1300   /* Try to match   ( <len-param> ) or ( <len-param> , [ KIND = ] <int> )  */
1301   m = char_len_param_value (&len);
1302   if (m == MATCH_NO)
1303     goto syntax;
1304   if (m == MATCH_ERROR)
1305     goto done;
1306   seen_length = 1;
1307
1308   m = gfc_match_char (')');
1309   if (m == MATCH_YES)
1310     goto done;
1311
1312   if (gfc_match_char (',') != MATCH_YES)
1313     goto syntax;
1314
1315   gfc_match (" kind =");        /* Gobble optional text */
1316
1317   m = gfc_match_small_int (&kind);
1318   if (m == MATCH_ERROR)
1319     goto done;
1320   if (m == MATCH_NO)
1321     goto syntax;
1322
1323 rparen:
1324   /* Require a right-paren at this point.  */
1325   m = gfc_match_char (')');
1326   if (m == MATCH_YES)
1327     goto done;
1328
1329 syntax:
1330   gfc_error ("Syntax error in CHARACTER declaration at %C");
1331   m = MATCH_ERROR;
1332
1333 done:
1334   if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1335     {
1336       gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1337       m = MATCH_ERROR;
1338     }
1339
1340   if (m != MATCH_YES)
1341     {
1342       gfc_free_expr (len);
1343       return m;
1344     }
1345
1346   /* Do some final massaging of the length values.  */
1347   cl = gfc_get_charlen ();
1348   cl->next = gfc_current_ns->cl_list;
1349   gfc_current_ns->cl_list = cl;
1350
1351   if (seen_length == 0)
1352     cl->length = gfc_int_expr (1);
1353   else
1354     {
1355       if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1356         cl->length = len;
1357       else
1358         {
1359           gfc_free_expr (len);
1360           cl->length = gfc_int_expr (0);
1361         }
1362     }
1363
1364   ts->cl = cl;
1365   ts->kind = kind;
1366
1367   return MATCH_YES;
1368 }
1369
1370
1371 /* Matches a type specification.  If successful, sets the ts structure
1372    to the matched specification.  This is necessary for FUNCTION and
1373    IMPLICIT statements.
1374
1375    If implicit_flag is nonzero, then we don't check for the optional
1376    kind specification.  Not doing so is needed for matching an IMPLICIT
1377    statement correctly.  */
1378
1379 static match
1380 match_type_spec (gfc_typespec * ts, int implicit_flag)
1381 {
1382   char name[GFC_MAX_SYMBOL_LEN + 1];
1383   gfc_symbol *sym;
1384   match m;
1385   int c;
1386
1387   gfc_clear_ts (ts);
1388
1389   if (gfc_match (" byte") == MATCH_YES)
1390     {
1391       if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1392           == FAILURE)
1393         return MATCH_ERROR;
1394
1395       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1396         {
1397           gfc_error ("BYTE type used at %C "
1398                      "is not available on the target machine");
1399           return MATCH_ERROR;
1400         }
1401
1402       ts->type = BT_INTEGER;
1403       ts->kind = 1;
1404       return MATCH_YES;
1405     }
1406
1407   if (gfc_match (" integer") == MATCH_YES)
1408     {
1409       ts->type = BT_INTEGER;
1410       ts->kind = gfc_default_integer_kind;
1411       goto get_kind;
1412     }
1413
1414   if (gfc_match (" character") == MATCH_YES)
1415     {
1416       ts->type = BT_CHARACTER;
1417       if (implicit_flag == 0)
1418         return match_char_spec (ts);
1419       else
1420         return MATCH_YES;
1421     }
1422
1423   if (gfc_match (" real") == MATCH_YES)
1424     {
1425       ts->type = BT_REAL;
1426       ts->kind = gfc_default_real_kind;
1427       goto get_kind;
1428     }
1429
1430   if (gfc_match (" double precision") == MATCH_YES)
1431     {
1432       ts->type = BT_REAL;
1433       ts->kind = gfc_default_double_kind;
1434       return MATCH_YES;
1435     }
1436
1437   if (gfc_match (" complex") == MATCH_YES)
1438     {
1439       ts->type = BT_COMPLEX;
1440       ts->kind = gfc_default_complex_kind;
1441       goto get_kind;
1442     }
1443
1444   if (gfc_match (" double complex") == MATCH_YES)
1445     {
1446       ts->type = BT_COMPLEX;
1447       ts->kind = gfc_default_double_kind;
1448       return MATCH_YES;
1449     }
1450
1451   if (gfc_match (" logical") == MATCH_YES)
1452     {
1453       ts->type = BT_LOGICAL;
1454       ts->kind = gfc_default_logical_kind;
1455       goto get_kind;
1456     }
1457
1458   m = gfc_match (" type ( %n )", name);
1459   if (m != MATCH_YES)
1460     return m;
1461
1462   /* Search for the name but allow the components to be defined later.  */
1463   if (gfc_get_ha_symbol (name, &sym))
1464     {
1465       gfc_error ("Type name '%s' at %C is ambiguous", name);
1466       return MATCH_ERROR;
1467     }
1468
1469   if (sym->attr.flavor != FL_DERIVED
1470       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1471     return MATCH_ERROR;
1472
1473   ts->type = BT_DERIVED;
1474   ts->kind = 0;
1475   ts->derived = sym;
1476
1477   return MATCH_YES;
1478
1479 get_kind:
1480   /* For all types except double, derived and character, look for an
1481      optional kind specifier.  MATCH_NO is actually OK at this point.  */
1482   if (implicit_flag == 1)
1483     return MATCH_YES;
1484
1485   if (gfc_current_form == FORM_FREE)
1486     {
1487       c = gfc_peek_char();
1488       if (!gfc_is_whitespace(c) && c != '*' && c != '('
1489          && c != ':' && c != ',')
1490        return MATCH_NO;
1491     }
1492
1493   m = gfc_match_kind_spec (ts);
1494   if (m == MATCH_NO && ts->type != BT_CHARACTER)
1495     m = gfc_match_old_kind_spec (ts);
1496
1497   if (m == MATCH_NO)
1498     m = MATCH_YES;              /* No kind specifier found.  */
1499
1500   return m;
1501 }
1502
1503
1504 /* Match an IMPLICIT NONE statement.  Actually, this statement is
1505    already matched in parse.c, or we would not end up here in the
1506    first place.  So the only thing we need to check, is if there is
1507    trailing garbage.  If not, the match is successful.  */
1508
1509 match
1510 gfc_match_implicit_none (void)
1511 {
1512
1513   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1514 }
1515
1516
1517 /* Match the letter range(s) of an IMPLICIT statement.  */
1518
1519 static match
1520 match_implicit_range (void)
1521 {
1522   int c, c1, c2, inner;
1523   locus cur_loc;
1524
1525   cur_loc = gfc_current_locus;
1526
1527   gfc_gobble_whitespace ();
1528   c = gfc_next_char ();
1529   if (c != '(')
1530     {
1531       gfc_error ("Missing character range in IMPLICIT at %C");
1532       goto bad;
1533     }
1534
1535   inner = 1;
1536   while (inner)
1537     {
1538       gfc_gobble_whitespace ();
1539       c1 = gfc_next_char ();
1540       if (!ISALPHA (c1))
1541         goto bad;
1542
1543       gfc_gobble_whitespace ();
1544       c = gfc_next_char ();
1545
1546       switch (c)
1547         {
1548         case ')':
1549           inner = 0;            /* Fall through */
1550
1551         case ',':
1552           c2 = c1;
1553           break;
1554
1555         case '-':
1556           gfc_gobble_whitespace ();
1557           c2 = gfc_next_char ();
1558           if (!ISALPHA (c2))
1559             goto bad;
1560
1561           gfc_gobble_whitespace ();
1562           c = gfc_next_char ();
1563
1564           if ((c != ',') && (c != ')'))
1565             goto bad;
1566           if (c == ')')
1567             inner = 0;
1568
1569           break;
1570
1571         default:
1572           goto bad;
1573         }
1574
1575       if (c1 > c2)
1576         {
1577           gfc_error ("Letters must be in alphabetic order in "
1578                      "IMPLICIT statement at %C");
1579           goto bad;
1580         }
1581
1582       /* See if we can add the newly matched range to the pending
1583          implicits from this IMPLICIT statement.  We do not check for
1584          conflicts with whatever earlier IMPLICIT statements may have
1585          set.  This is done when we've successfully finished matching
1586          the current one.  */
1587       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1588         goto bad;
1589     }
1590
1591   return MATCH_YES;
1592
1593 bad:
1594   gfc_syntax_error (ST_IMPLICIT);
1595
1596   gfc_current_locus = cur_loc;
1597   return MATCH_ERROR;
1598 }
1599
1600
1601 /* Match an IMPLICIT statement, storing the types for
1602    gfc_set_implicit() if the statement is accepted by the parser.
1603    There is a strange looking, but legal syntactic construction
1604    possible.  It looks like:
1605
1606      IMPLICIT INTEGER (a-b) (c-d)
1607
1608    This is legal if "a-b" is a constant expression that happens to
1609    equal one of the legal kinds for integers.  The real problem
1610    happens with an implicit specification that looks like:
1611
1612      IMPLICIT INTEGER (a-b)
1613
1614    In this case, a typespec matcher that is "greedy" (as most of the
1615    matchers are) gobbles the character range as a kindspec, leaving
1616    nothing left.  We therefore have to go a bit more slowly in the
1617    matching process by inhibiting the kindspec checking during
1618    typespec matching and checking for a kind later.  */
1619
1620 match
1621 gfc_match_implicit (void)
1622 {
1623   gfc_typespec ts;
1624   locus cur_loc;
1625   int c;
1626   match m;
1627
1628   /* We don't allow empty implicit statements.  */
1629   if (gfc_match_eos () == MATCH_YES)
1630     {
1631       gfc_error ("Empty IMPLICIT statement at %C");
1632       return MATCH_ERROR;
1633     }
1634
1635   do
1636     {
1637       /* First cleanup.  */
1638       gfc_clear_new_implicit ();
1639
1640       /* A basic type is mandatory here.  */
1641       m = match_type_spec (&ts, 1);
1642       if (m == MATCH_ERROR)
1643         goto error;
1644       if (m == MATCH_NO)
1645         goto syntax;
1646
1647       cur_loc = gfc_current_locus;
1648       m = match_implicit_range ();
1649
1650       if (m == MATCH_YES)
1651         {
1652           /* We may have <TYPE> (<RANGE>).  */
1653           gfc_gobble_whitespace ();
1654           c = gfc_next_char ();
1655           if ((c == '\n') || (c == ','))
1656             {
1657               /* Check for CHARACTER with no length parameter.  */
1658               if (ts.type == BT_CHARACTER && !ts.cl)
1659                 {
1660                   ts.kind = gfc_default_character_kind;
1661                   ts.cl = gfc_get_charlen ();
1662                   ts.cl->next = gfc_current_ns->cl_list;
1663                   gfc_current_ns->cl_list = ts.cl;
1664                   ts.cl->length = gfc_int_expr (1);
1665                 }
1666
1667               /* Record the Successful match.  */
1668               if (gfc_merge_new_implicit (&ts) != SUCCESS)
1669                 return MATCH_ERROR;
1670               continue;
1671             }
1672
1673           gfc_current_locus = cur_loc;
1674         }
1675
1676       /* Discard the (incorrectly) matched range.  */
1677       gfc_clear_new_implicit ();
1678
1679       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
1680       if (ts.type == BT_CHARACTER)
1681         m = match_char_spec (&ts);
1682       else
1683         {
1684           m = gfc_match_kind_spec (&ts);
1685           if (m == MATCH_NO)
1686             {
1687               m = gfc_match_old_kind_spec (&ts);
1688               if (m == MATCH_ERROR)
1689                 goto error;
1690               if (m == MATCH_NO)
1691                 goto syntax;
1692             }
1693         }
1694       if (m == MATCH_ERROR)
1695         goto error;
1696
1697       m = match_implicit_range ();
1698       if (m == MATCH_ERROR)
1699         goto error;
1700       if (m == MATCH_NO)
1701         goto syntax;
1702
1703       gfc_gobble_whitespace ();
1704       c = gfc_next_char ();
1705       if ((c != '\n') && (c != ','))
1706         goto syntax;
1707
1708       if (gfc_merge_new_implicit (&ts) != SUCCESS)
1709         return MATCH_ERROR;
1710     }
1711   while (c == ',');
1712
1713   return MATCH_YES;
1714
1715 syntax:
1716   gfc_syntax_error (ST_IMPLICIT);
1717
1718 error:
1719   return MATCH_ERROR;
1720 }
1721
1722
1723 /* Matches an attribute specification including array specs.  If
1724    successful, leaves the variables current_attr and current_as
1725    holding the specification.  Also sets the colon_seen variable for
1726    later use by matchers associated with initializations.
1727
1728    This subroutine is a little tricky in the sense that we don't know
1729    if we really have an attr-spec until we hit the double colon.
1730    Until that time, we can only return MATCH_NO.  This forces us to
1731    check for duplicate specification at this level.  */
1732
1733 static match
1734 match_attr_spec (void)
1735 {
1736
1737   /* Modifiers that can exist in a type statement.  */
1738   typedef enum
1739   { GFC_DECL_BEGIN = 0,
1740     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1741     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1742     DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1743     DECL_TARGET, DECL_COLON, DECL_NONE,
1744     GFC_DECL_END /* Sentinel */
1745   }
1746   decl_types;
1747
1748 /* GFC_DECL_END is the sentinel, index starts at 0.  */
1749 #define NUM_DECL GFC_DECL_END
1750
1751   static mstring decls[] = {
1752     minit (", allocatable", DECL_ALLOCATABLE),
1753     minit (", dimension", DECL_DIMENSION),
1754     minit (", external", DECL_EXTERNAL),
1755     minit (", intent ( in )", DECL_IN),
1756     minit (", intent ( out )", DECL_OUT),
1757     minit (", intent ( in out )", DECL_INOUT),
1758     minit (", intrinsic", DECL_INTRINSIC),
1759     minit (", optional", DECL_OPTIONAL),
1760     minit (", parameter", DECL_PARAMETER),
1761     minit (", pointer", DECL_POINTER),
1762     minit (", private", DECL_PRIVATE),
1763     minit (", public", DECL_PUBLIC),
1764     minit (", save", DECL_SAVE),
1765     minit (", target", DECL_TARGET),
1766     minit ("::", DECL_COLON),
1767     minit (NULL, DECL_NONE)
1768   };
1769
1770   locus start, seen_at[NUM_DECL];
1771   int seen[NUM_DECL];
1772   decl_types d;
1773   const char *attr;
1774   match m;
1775   try t;
1776
1777   gfc_clear_attr (&current_attr);
1778   start = gfc_current_locus;
1779
1780   current_as = NULL;
1781   colon_seen = 0;
1782
1783   /* See if we get all of the keywords up to the final double colon.  */
1784   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1785     seen[d] = 0;
1786
1787   for (;;)
1788     {
1789       d = (decl_types) gfc_match_strings (decls);
1790       if (d == DECL_NONE || d == DECL_COLON)
1791         break;
1792
1793       seen[d]++;
1794       seen_at[d] = gfc_current_locus;
1795
1796       if (d == DECL_DIMENSION)
1797         {
1798           m = gfc_match_array_spec (&current_as);
1799
1800           if (m == MATCH_NO)
1801             {
1802               gfc_error ("Missing dimension specification at %C");
1803               m = MATCH_ERROR;
1804             }
1805
1806           if (m == MATCH_ERROR)
1807             goto cleanup;
1808         }
1809     }
1810
1811   /* No double colon, so assume that we've been looking at something
1812      else the whole time.  */
1813   if (d == DECL_NONE)
1814     {
1815       m = MATCH_NO;
1816       goto cleanup;
1817     }
1818
1819   /* Since we've seen a double colon, we have to be looking at an
1820      attr-spec.  This means that we can now issue errors.  */
1821   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1822     if (seen[d] > 1)
1823       {
1824         switch (d)
1825           {
1826           case DECL_ALLOCATABLE:
1827             attr = "ALLOCATABLE";
1828             break;
1829           case DECL_DIMENSION:
1830             attr = "DIMENSION";
1831             break;
1832           case DECL_EXTERNAL:
1833             attr = "EXTERNAL";
1834             break;
1835           case DECL_IN:
1836             attr = "INTENT (IN)";
1837             break;
1838           case DECL_OUT:
1839             attr = "INTENT (OUT)";
1840             break;
1841           case DECL_INOUT:
1842             attr = "INTENT (IN OUT)";
1843             break;
1844           case DECL_INTRINSIC:
1845             attr = "INTRINSIC";
1846             break;
1847           case DECL_OPTIONAL:
1848             attr = "OPTIONAL";
1849             break;
1850           case DECL_PARAMETER:
1851             attr = "PARAMETER";
1852             break;
1853           case DECL_POINTER:
1854             attr = "POINTER";
1855             break;
1856           case DECL_PRIVATE:
1857             attr = "PRIVATE";
1858             break;
1859           case DECL_PUBLIC:
1860             attr = "PUBLIC";
1861             break;
1862           case DECL_SAVE:
1863             attr = "SAVE";
1864             break;
1865           case DECL_TARGET:
1866             attr = "TARGET";
1867             break;
1868           default:
1869             attr = NULL;        /* This shouldn't happen */
1870           }
1871
1872         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1873         m = MATCH_ERROR;
1874         goto cleanup;
1875       }
1876
1877   /* Now that we've dealt with duplicate attributes, add the attributes
1878      to the current attribute.  */
1879   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1880     {
1881       if (seen[d] == 0)
1882         continue;
1883
1884       if (gfc_current_state () == COMP_DERIVED
1885           && d != DECL_DIMENSION && d != DECL_POINTER
1886           && d != DECL_COLON && d != DECL_NONE)
1887         {
1888
1889           gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1890                      &seen_at[d]);
1891           m = MATCH_ERROR;
1892           goto cleanup;
1893         }
1894
1895       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
1896              && gfc_current_state () != COMP_MODULE)
1897         {
1898           if (d == DECL_PRIVATE)
1899             attr = "PRIVATE";
1900           else
1901             attr = "PUBLIC";
1902
1903           gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
1904                      attr, &seen_at[d]);
1905           m = MATCH_ERROR;
1906           goto cleanup;
1907         }
1908
1909       switch (d)
1910         {
1911         case DECL_ALLOCATABLE:
1912           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
1913           break;
1914
1915         case DECL_DIMENSION:
1916           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
1917           break;
1918
1919         case DECL_EXTERNAL:
1920           t = gfc_add_external (&current_attr, &seen_at[d]);
1921           break;
1922
1923         case DECL_IN:
1924           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
1925           break;
1926
1927         case DECL_OUT:
1928           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
1929           break;
1930
1931         case DECL_INOUT:
1932           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
1933           break;
1934
1935         case DECL_INTRINSIC:
1936           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
1937           break;
1938
1939         case DECL_OPTIONAL:
1940           t = gfc_add_optional (&current_attr, &seen_at[d]);
1941           break;
1942
1943         case DECL_PARAMETER:
1944           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
1945           break;
1946
1947         case DECL_POINTER:
1948           t = gfc_add_pointer (&current_attr, &seen_at[d]);
1949           break;
1950
1951         case DECL_PRIVATE:
1952           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
1953                               &seen_at[d]);
1954           break;
1955
1956         case DECL_PUBLIC:
1957           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
1958                               &seen_at[d]);
1959           break;
1960
1961         case DECL_SAVE:
1962           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
1963           break;
1964
1965         case DECL_TARGET:
1966           t = gfc_add_target (&current_attr, &seen_at[d]);
1967           break;
1968
1969         default:
1970           gfc_internal_error ("match_attr_spec(): Bad attribute");
1971         }
1972
1973       if (t == FAILURE)
1974         {
1975           m = MATCH_ERROR;
1976           goto cleanup;
1977         }
1978     }
1979
1980   colon_seen = 1;
1981   return MATCH_YES;
1982
1983 cleanup:
1984   gfc_current_locus = start;
1985   gfc_free_array_spec (current_as);
1986   current_as = NULL;
1987   return m;
1988 }
1989
1990
1991 /* Match a data declaration statement.  */
1992
1993 match
1994 gfc_match_data_decl (void)
1995 {
1996   gfc_symbol *sym;
1997   match m;
1998   int elem;
1999
2000   m = match_type_spec (&current_ts, 0);
2001   if (m != MATCH_YES)
2002     return m;
2003
2004   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2005     {
2006       sym = gfc_use_derived (current_ts.derived);
2007
2008       if (sym == NULL)
2009         {
2010           m = MATCH_ERROR;
2011           goto cleanup;
2012         }
2013
2014       current_ts.derived = sym;
2015     }
2016
2017   m = match_attr_spec ();
2018   if (m == MATCH_ERROR)
2019     {
2020       m = MATCH_NO;
2021       goto cleanup;
2022     }
2023
2024   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2025     {
2026
2027       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2028         goto ok;
2029
2030       if (gfc_find_symbol (current_ts.derived->name,
2031                            current_ts.derived->ns->parent, 1, &sym) == 0)
2032         goto ok;
2033
2034       /* Hope that an ambiguous symbol is itself masked by a type definition.  */
2035       if (sym != NULL && sym->attr.flavor == FL_DERIVED)
2036         goto ok;
2037
2038       gfc_error ("Derived type at %C has not been previously defined");
2039       m = MATCH_ERROR;
2040       goto cleanup;
2041     }
2042
2043 ok:
2044   /* If we have an old-style character declaration, and no new-style
2045      attribute specifications, then there a comma is optional between
2046      the type specification and the variable list.  */
2047   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2048     gfc_match_char (',');
2049
2050   /* Give the types/attributes to symbols that follow. Give the element
2051      a number so that repeat character length expressions can be copied.  */
2052   elem = 1;
2053   for (;;)
2054     {
2055       m = variable_decl (elem++);
2056       if (m == MATCH_ERROR)
2057         goto cleanup;
2058       if (m == MATCH_NO)
2059         break;
2060
2061       if (gfc_match_eos () == MATCH_YES)
2062         goto cleanup;
2063       if (gfc_match_char (',') != MATCH_YES)
2064         break;
2065     }
2066
2067   gfc_error ("Syntax error in data declaration at %C");
2068   m = MATCH_ERROR;
2069
2070 cleanup:
2071   gfc_free_array_spec (current_as);
2072   current_as = NULL;
2073   return m;
2074 }
2075
2076
2077 /* Match a prefix associated with a function or subroutine
2078    declaration.  If the typespec pointer is nonnull, then a typespec
2079    can be matched.  Note that if nothing matches, MATCH_YES is
2080    returned (the null string was matched).  */
2081
2082 static match
2083 match_prefix (gfc_typespec * ts)
2084 {
2085   int seen_type;
2086
2087   gfc_clear_attr (&current_attr);
2088   seen_type = 0;
2089
2090 loop:
2091   if (!seen_type && ts != NULL
2092       && match_type_spec (ts, 0) == MATCH_YES
2093       && gfc_match_space () == MATCH_YES)
2094     {
2095
2096       seen_type = 1;
2097       goto loop;
2098     }
2099
2100   if (gfc_match ("elemental% ") == MATCH_YES)
2101     {
2102       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
2103         return MATCH_ERROR;
2104
2105       goto loop;
2106     }
2107
2108   if (gfc_match ("pure% ") == MATCH_YES)
2109     {
2110       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
2111         return MATCH_ERROR;
2112
2113       goto loop;
2114     }
2115
2116   if (gfc_match ("recursive% ") == MATCH_YES)
2117     {
2118       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
2119         return MATCH_ERROR;
2120
2121       goto loop;
2122     }
2123
2124   /* At this point, the next item is not a prefix.  */
2125   return MATCH_YES;
2126 }
2127
2128
2129 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
2130
2131 static try
2132 copy_prefix (symbol_attribute * dest, locus * where)
2133 {
2134
2135   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2136     return FAILURE;
2137
2138   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2139     return FAILURE;
2140
2141   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2142     return FAILURE;
2143
2144   return SUCCESS;
2145 }
2146
2147
2148 /* Match a formal argument list.  */
2149
2150 match
2151 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2152 {
2153   gfc_formal_arglist *head, *tail, *p, *q;
2154   char name[GFC_MAX_SYMBOL_LEN + 1];
2155   gfc_symbol *sym;
2156   match m;
2157
2158   head = tail = NULL;
2159
2160   if (gfc_match_char ('(') != MATCH_YES)
2161     {
2162       if (null_flag)
2163         goto ok;
2164       return MATCH_NO;
2165     }
2166
2167   if (gfc_match_char (')') == MATCH_YES)
2168     goto ok;
2169
2170   for (;;)
2171     {
2172       if (gfc_match_char ('*') == MATCH_YES)
2173         sym = NULL;
2174       else
2175         {
2176           m = gfc_match_name (name);
2177           if (m != MATCH_YES)
2178             goto cleanup;
2179
2180           if (gfc_get_symbol (name, NULL, &sym))
2181             goto cleanup;
2182         }
2183
2184       p = gfc_get_formal_arglist ();
2185
2186       if (head == NULL)
2187         head = tail = p;
2188       else
2189         {
2190           tail->next = p;
2191           tail = p;
2192         }
2193
2194       tail->sym = sym;
2195
2196       /* We don't add the VARIABLE flavor because the name could be a
2197          dummy procedure.  We don't apply these attributes to formal
2198          arguments of statement functions.  */
2199       if (sym != NULL && !st_flag
2200           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2201               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2202         {
2203           m = MATCH_ERROR;
2204           goto cleanup;
2205         }
2206
2207       /* The name of a program unit can be in a different namespace,
2208          so check for it explicitly.  After the statement is accepted,
2209          the name is checked for especially in gfc_get_symbol().  */
2210       if (gfc_new_block != NULL && sym != NULL
2211           && strcmp (sym->name, gfc_new_block->name) == 0)
2212         {
2213           gfc_error ("Name '%s' at %C is the name of the procedure",
2214                      sym->name);
2215           m = MATCH_ERROR;
2216           goto cleanup;
2217         }
2218
2219       if (gfc_match_char (')') == MATCH_YES)
2220         goto ok;
2221
2222       m = gfc_match_char (',');
2223       if (m != MATCH_YES)
2224         {
2225           gfc_error ("Unexpected junk in formal argument list at %C");
2226           goto cleanup;
2227         }
2228     }
2229
2230 ok:
2231   /* Check for duplicate symbols in the formal argument list.  */
2232   if (head != NULL)
2233     {
2234       for (p = head; p->next; p = p->next)
2235         {
2236           if (p->sym == NULL)
2237             continue;
2238
2239           for (q = p->next; q; q = q->next)
2240             if (p->sym == q->sym)
2241               {
2242                 gfc_error
2243                   ("Duplicate symbol '%s' in formal argument list at %C",
2244                    p->sym->name);
2245
2246                 m = MATCH_ERROR;
2247                 goto cleanup;
2248               }
2249         }
2250     }
2251
2252   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2253       FAILURE)
2254     {
2255       m = MATCH_ERROR;
2256       goto cleanup;
2257     }
2258
2259   return MATCH_YES;
2260
2261 cleanup:
2262   gfc_free_formal_arglist (head);
2263   return m;
2264 }
2265
2266
2267 /* Match a RESULT specification following a function declaration or
2268    ENTRY statement.  Also matches the end-of-statement.  */
2269
2270 static match
2271 match_result (gfc_symbol * function, gfc_symbol ** result)
2272 {
2273   char name[GFC_MAX_SYMBOL_LEN + 1];
2274   gfc_symbol *r;
2275   match m;
2276
2277   if (gfc_match (" result (") != MATCH_YES)
2278     return MATCH_NO;
2279
2280   m = gfc_match_name (name);
2281   if (m != MATCH_YES)
2282     return m;
2283
2284   if (gfc_match (" )%t") != MATCH_YES)
2285     {
2286       gfc_error ("Unexpected junk following RESULT variable at %C");
2287       return MATCH_ERROR;
2288     }
2289
2290   if (strcmp (function->name, name) == 0)
2291     {
2292       gfc_error
2293         ("RESULT variable at %C must be different than function name");
2294       return MATCH_ERROR;
2295     }
2296
2297   if (gfc_get_symbol (name, NULL, &r))
2298     return MATCH_ERROR;
2299
2300   if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2301       || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2302     return MATCH_ERROR;
2303
2304   *result = r;
2305
2306   return MATCH_YES;
2307 }
2308
2309
2310 /* Match a function declaration.  */
2311
2312 match
2313 gfc_match_function_decl (void)
2314 {
2315   char name[GFC_MAX_SYMBOL_LEN + 1];
2316   gfc_symbol *sym, *result;
2317   locus old_loc;
2318   match m;
2319
2320   if (gfc_current_state () != COMP_NONE
2321       && gfc_current_state () != COMP_INTERFACE
2322       && gfc_current_state () != COMP_CONTAINS)
2323     return MATCH_NO;
2324
2325   gfc_clear_ts (&current_ts);
2326
2327   old_loc = gfc_current_locus;
2328
2329   m = match_prefix (&current_ts);
2330   if (m != MATCH_YES)
2331     {
2332       gfc_current_locus = old_loc;
2333       return m;
2334     }
2335
2336   if (gfc_match ("function% %n", name) != MATCH_YES)
2337     {
2338       gfc_current_locus = old_loc;
2339       return MATCH_NO;
2340     }
2341
2342   if (get_proc_name (name, &sym))
2343     return MATCH_ERROR;
2344   gfc_new_block = sym;
2345
2346   m = gfc_match_formal_arglist (sym, 0, 0);
2347   if (m == MATCH_NO)
2348     gfc_error ("Expected formal argument list in function definition at %C");
2349   else if (m == MATCH_ERROR)
2350     goto cleanup;
2351
2352   result = NULL;
2353
2354   if (gfc_match_eos () != MATCH_YES)
2355     {
2356       /* See if a result variable is present.  */
2357       m = match_result (sym, &result);
2358       if (m == MATCH_NO)
2359         gfc_error ("Unexpected junk after function declaration at %C");
2360
2361       if (m != MATCH_YES)
2362         {
2363           m = MATCH_ERROR;
2364           goto cleanup;
2365         }
2366     }
2367
2368   /* Make changes to the symbol.  */
2369   m = MATCH_ERROR;
2370
2371   if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2372     goto cleanup;
2373
2374   if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2375       || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2376     goto cleanup;
2377
2378   if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
2379     {
2380       gfc_error ("Function '%s' at %C already has a type of %s", name,
2381                  gfc_basic_typename (sym->ts.type));
2382       goto cleanup;
2383     }
2384
2385   if (result == NULL)
2386     {
2387       sym->ts = current_ts;
2388       sym->result = sym;
2389     }
2390   else
2391     {
2392       result->ts = current_ts;
2393       sym->result = result;
2394     }
2395
2396   return MATCH_YES;
2397
2398 cleanup:
2399   gfc_current_locus = old_loc;
2400   return m;
2401 }
2402
2403
2404 /* Match an ENTRY statement.  */
2405
2406 match
2407 gfc_match_entry (void)
2408 {
2409   gfc_symbol *proc;
2410   gfc_symbol *result;
2411   gfc_symbol *entry;
2412   char name[GFC_MAX_SYMBOL_LEN + 1];
2413   gfc_compile_state state;
2414   match m;
2415   gfc_entry_list *el;
2416
2417   m = gfc_match_name (name);
2418   if (m != MATCH_YES)
2419     return m;
2420
2421   state = gfc_current_state ();
2422   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2423     {
2424       switch (state)
2425         {
2426           case COMP_PROGRAM:
2427             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2428             break;
2429           case COMP_MODULE:
2430             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2431             break;
2432           case COMP_BLOCK_DATA:
2433             gfc_error
2434               ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2435             break;
2436           case COMP_INTERFACE:
2437             gfc_error
2438               ("ENTRY statement at %C cannot appear within an INTERFACE");
2439             break;
2440           case COMP_DERIVED:
2441             gfc_error
2442               ("ENTRY statement at %C cannot appear "
2443                "within a DERIVED TYPE block");
2444             break;
2445           case COMP_IF:
2446             gfc_error
2447               ("ENTRY statement at %C cannot appear within an IF-THEN block");
2448             break;
2449           case COMP_DO:
2450             gfc_error
2451               ("ENTRY statement at %C cannot appear within a DO block");
2452             break;
2453           case COMP_SELECT:
2454             gfc_error
2455               ("ENTRY statement at %C cannot appear within a SELECT block");
2456             break;
2457           case COMP_FORALL:
2458             gfc_error
2459               ("ENTRY statement at %C cannot appear within a FORALL block");
2460             break;
2461           case COMP_WHERE:
2462             gfc_error
2463               ("ENTRY statement at %C cannot appear within a WHERE block");
2464             break;
2465           case COMP_CONTAINS:
2466             gfc_error
2467               ("ENTRY statement at %C cannot appear "
2468                "within a contained subprogram");
2469             break;
2470           default:
2471             gfc_internal_error ("gfc_match_entry(): Bad state");
2472         }
2473       return MATCH_ERROR;
2474     }
2475
2476   if (gfc_current_ns->parent != NULL
2477       && gfc_current_ns->parent->proc_name
2478       && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
2479     {
2480       gfc_error("ENTRY statement at %C cannot appear in a "
2481                 "contained procedure");
2482       return MATCH_ERROR;
2483     }
2484
2485   if (get_proc_name (name, &entry))
2486     return MATCH_ERROR;
2487
2488   proc = gfc_current_block ();
2489
2490   if (state == COMP_SUBROUTINE)
2491     {
2492       /* An entry in a subroutine.  */
2493       m = gfc_match_formal_arglist (entry, 0, 1);
2494       if (m != MATCH_YES)
2495         return MATCH_ERROR;
2496
2497       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2498           || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2499         return MATCH_ERROR;
2500     }
2501   else
2502     {
2503       /* An entry in a function.  */
2504       m = gfc_match_formal_arglist (entry, 0, 1);
2505       if (m != MATCH_YES)
2506         return MATCH_ERROR;
2507
2508       result = NULL;
2509
2510       if (gfc_match_eos () == MATCH_YES)
2511         {
2512           if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2513               || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
2514             return MATCH_ERROR;
2515
2516           entry->result = entry;
2517         }
2518       else
2519         {
2520           m = match_result (proc, &result);
2521           if (m == MATCH_NO)
2522             gfc_syntax_error (ST_ENTRY);
2523           if (m != MATCH_YES)
2524             return MATCH_ERROR;
2525
2526           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2527               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2528               || gfc_add_function (&entry->attr, result->name,
2529                                    NULL) == FAILURE)
2530             return MATCH_ERROR;
2531
2532           entry->result = result;
2533         }
2534
2535       if (proc->attr.recursive && result == NULL)
2536         {
2537           gfc_error ("RESULT attribute required in ENTRY statement at %C");
2538           return MATCH_ERROR;
2539         }
2540     }
2541
2542   if (gfc_match_eos () != MATCH_YES)
2543     {
2544       gfc_syntax_error (ST_ENTRY);
2545       return MATCH_ERROR;
2546     }
2547
2548   entry->attr.recursive = proc->attr.recursive;
2549   entry->attr.elemental = proc->attr.elemental;
2550   entry->attr.pure = proc->attr.pure;
2551
2552   el = gfc_get_entry_list ();
2553   el->sym = entry;
2554   el->next = gfc_current_ns->entries;
2555   gfc_current_ns->entries = el;
2556   if (el->next)
2557     el->id = el->next->id + 1;
2558   else
2559     el->id = 1;
2560
2561   new_st.op = EXEC_ENTRY;
2562   new_st.ext.entry = el;
2563
2564   return MATCH_YES;
2565 }
2566
2567
2568 /* Match a subroutine statement, including optional prefixes.  */
2569
2570 match
2571 gfc_match_subroutine (void)
2572 {
2573   char name[GFC_MAX_SYMBOL_LEN + 1];
2574   gfc_symbol *sym;
2575   match m;
2576
2577   if (gfc_current_state () != COMP_NONE
2578       && gfc_current_state () != COMP_INTERFACE
2579       && gfc_current_state () != COMP_CONTAINS)
2580     return MATCH_NO;
2581
2582   m = match_prefix (NULL);
2583   if (m != MATCH_YES)
2584     return m;
2585
2586   m = gfc_match ("subroutine% %n", name);
2587   if (m != MATCH_YES)
2588     return m;
2589
2590   if (get_proc_name (name, &sym))
2591     return MATCH_ERROR;
2592   gfc_new_block = sym;
2593
2594   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2595     return MATCH_ERROR;
2596
2597   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2598     return MATCH_ERROR;
2599
2600   if (gfc_match_eos () != MATCH_YES)
2601     {
2602       gfc_syntax_error (ST_SUBROUTINE);
2603       return MATCH_ERROR;
2604     }
2605
2606   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2607     return MATCH_ERROR;
2608
2609   return MATCH_YES;
2610 }
2611
2612
2613 /* Return nonzero if we're currently compiling a contained procedure.  */
2614
2615 static int
2616 contained_procedure (void)
2617 {
2618   gfc_state_data *s;
2619
2620   for (s=gfc_state_stack; s; s=s->previous)
2621     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2622        && s->previous != NULL
2623        && s->previous->state == COMP_CONTAINS)
2624       return 1;
2625
2626   return 0;
2627 }
2628
2629 /* Match any of the various end-block statements.  Returns the type of
2630    END to the caller.  The END INTERFACE, END IF, END DO and END
2631    SELECT statements cannot be replaced by a single END statement.  */
2632
2633 match
2634 gfc_match_end (gfc_statement * st)
2635 {
2636   char name[GFC_MAX_SYMBOL_LEN + 1];
2637   gfc_compile_state state;
2638   locus old_loc;
2639   const char *block_name;
2640   const char *target;
2641   int eos_ok;
2642   match m;
2643
2644   old_loc = gfc_current_locus;
2645   if (gfc_match ("end") != MATCH_YES)
2646     return MATCH_NO;
2647
2648   state = gfc_current_state ();
2649   block_name =
2650     gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2651
2652   if (state == COMP_CONTAINS)
2653     {
2654       state = gfc_state_stack->previous->state;
2655       block_name = gfc_state_stack->previous->sym == NULL ? NULL
2656         : gfc_state_stack->previous->sym->name;
2657     }
2658
2659   switch (state)
2660     {
2661     case COMP_NONE:
2662     case COMP_PROGRAM:
2663       *st = ST_END_PROGRAM;
2664       target = " program";
2665       eos_ok = 1;
2666       break;
2667
2668     case COMP_SUBROUTINE:
2669       *st = ST_END_SUBROUTINE;
2670       target = " subroutine";
2671       eos_ok = !contained_procedure ();
2672       break;
2673
2674     case COMP_FUNCTION:
2675       *st = ST_END_FUNCTION;
2676       target = " function";
2677       eos_ok = !contained_procedure ();
2678       break;
2679
2680     case COMP_BLOCK_DATA:
2681       *st = ST_END_BLOCK_DATA;
2682       target = " block data";
2683       eos_ok = 1;
2684       break;
2685
2686     case COMP_MODULE:
2687       *st = ST_END_MODULE;
2688       target = " module";
2689       eos_ok = 1;
2690       break;
2691
2692     case COMP_INTERFACE:
2693       *st = ST_END_INTERFACE;
2694       target = " interface";
2695       eos_ok = 0;
2696       break;
2697
2698     case COMP_DERIVED:
2699       *st = ST_END_TYPE;
2700       target = " type";
2701       eos_ok = 0;
2702       break;
2703
2704     case COMP_IF:
2705       *st = ST_ENDIF;
2706       target = " if";
2707       eos_ok = 0;
2708       break;
2709
2710     case COMP_DO:
2711       *st = ST_ENDDO;
2712       target = " do";
2713       eos_ok = 0;
2714       break;
2715
2716     case COMP_SELECT:
2717       *st = ST_END_SELECT;
2718       target = " select";
2719       eos_ok = 0;
2720       break;
2721
2722     case COMP_FORALL:
2723       *st = ST_END_FORALL;
2724       target = " forall";
2725       eos_ok = 0;
2726       break;
2727
2728     case COMP_WHERE:
2729       *st = ST_END_WHERE;
2730       target = " where";
2731       eos_ok = 0;
2732       break;
2733
2734     default:
2735       gfc_error ("Unexpected END statement at %C");
2736       goto cleanup;
2737     }
2738
2739   if (gfc_match_eos () == MATCH_YES)
2740     {
2741       if (!eos_ok)
2742         {
2743           /* We would have required END [something]  */
2744           gfc_error ("%s statement expected at %L",
2745                      gfc_ascii_statement (*st), &old_loc);
2746           goto cleanup;
2747         }
2748
2749       return MATCH_YES;
2750     }
2751
2752   /* Verify that we've got the sort of end-block that we're expecting.  */
2753   if (gfc_match (target) != MATCH_YES)
2754     {
2755       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
2756       goto cleanup;
2757     }
2758
2759   /* If we're at the end, make sure a block name wasn't required.  */
2760   if (gfc_match_eos () == MATCH_YES)
2761     {
2762
2763       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
2764         return MATCH_YES;
2765
2766       if (gfc_current_block () == NULL)
2767         return MATCH_YES;
2768
2769       gfc_error ("Expected block name of '%s' in %s statement at %C",
2770                  block_name, gfc_ascii_statement (*st));
2771
2772       return MATCH_ERROR;
2773     }
2774
2775   /* END INTERFACE has a special handler for its several possible endings.  */
2776   if (*st == ST_END_INTERFACE)
2777     return gfc_match_end_interface ();
2778
2779   /* We haven't hit the end of statement, so what is left must be an end-name.  */
2780   m = gfc_match_space ();
2781   if (m == MATCH_YES)
2782     m = gfc_match_name (name);
2783
2784   if (m == MATCH_NO)
2785     gfc_error ("Expected terminating name at %C");
2786   if (m != MATCH_YES)
2787     goto cleanup;
2788
2789   if (block_name == NULL)
2790     goto syntax;
2791
2792   if (strcmp (name, block_name) != 0)
2793     {
2794       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
2795                  gfc_ascii_statement (*st));
2796       goto cleanup;
2797     }
2798
2799   if (gfc_match_eos () == MATCH_YES)
2800     return MATCH_YES;
2801
2802 syntax:
2803   gfc_syntax_error (*st);
2804
2805 cleanup:
2806   gfc_current_locus = old_loc;
2807   return MATCH_ERROR;
2808 }
2809
2810
2811
2812 /***************** Attribute declaration statements ****************/
2813
2814 /* Set the attribute of a single variable.  */
2815
2816 static match
2817 attr_decl1 (void)
2818 {
2819   char name[GFC_MAX_SYMBOL_LEN + 1];
2820   gfc_array_spec *as;
2821   gfc_symbol *sym;
2822   locus var_locus;
2823   match m;
2824
2825   as = NULL;
2826
2827   m = gfc_match_name (name);
2828   if (m != MATCH_YES)
2829     goto cleanup;
2830
2831   if (find_special (name, &sym))
2832     return MATCH_ERROR;
2833
2834   var_locus = gfc_current_locus;
2835
2836   /* Deal with possible array specification for certain attributes.  */
2837   if (current_attr.dimension
2838       || current_attr.allocatable
2839       || current_attr.pointer
2840       || current_attr.target)
2841     {
2842       m = gfc_match_array_spec (&as);
2843       if (m == MATCH_ERROR)
2844         goto cleanup;
2845
2846       if (current_attr.dimension && m == MATCH_NO)
2847         {
2848           gfc_error
2849             ("Missing array specification at %L in DIMENSION statement",
2850              &var_locus);
2851           m = MATCH_ERROR;
2852           goto cleanup;
2853         }
2854
2855       if ((current_attr.allocatable || current_attr.pointer)
2856           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2857         {
2858           gfc_error ("Array specification must be deferred at %L",
2859                      &var_locus);
2860           m = MATCH_ERROR;
2861           goto cleanup;
2862         }
2863     }
2864
2865   /* Update symbol table.  DIMENSION attribute is set in gfc_set_array_spec().  */
2866   if (current_attr.dimension == 0
2867       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2868     {
2869       m = MATCH_ERROR;
2870       goto cleanup;
2871     }
2872
2873   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2874     {
2875       m = MATCH_ERROR;
2876       goto cleanup;
2877     }
2878
2879   if ((current_attr.external || current_attr.intrinsic)
2880       && sym->attr.flavor != FL_PROCEDURE
2881       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
2882     {
2883       m = MATCH_ERROR;
2884       goto cleanup;
2885     }
2886
2887   return MATCH_YES;
2888
2889 cleanup:
2890   gfc_free_array_spec (as);
2891   return m;
2892 }
2893
2894
2895 /* Generic attribute declaration subroutine.  Used for attributes that
2896    just have a list of names.  */
2897
2898 static match
2899 attr_decl (void)
2900 {
2901   match m;
2902
2903   /* Gobble the optional double colon, by simply ignoring the result
2904      of gfc_match().  */
2905   gfc_match (" ::");
2906
2907   for (;;)
2908     {
2909       m = attr_decl1 ();
2910       if (m != MATCH_YES)
2911         break;
2912
2913       if (gfc_match_eos () == MATCH_YES)
2914         {
2915           m = MATCH_YES;
2916           break;
2917         }
2918
2919       if (gfc_match_char (',') != MATCH_YES)
2920         {
2921           gfc_error ("Unexpected character in variable list at %C");
2922           m = MATCH_ERROR;
2923           break;
2924         }
2925     }
2926
2927   return m;
2928 }
2929
2930
2931 match
2932 gfc_match_external (void)
2933 {
2934
2935   gfc_clear_attr (&current_attr);
2936   gfc_add_external (&current_attr, NULL);
2937
2938   return attr_decl ();
2939 }
2940
2941
2942
2943 match
2944 gfc_match_intent (void)
2945 {
2946   sym_intent intent;
2947
2948   intent = match_intent_spec ();
2949   if (intent == INTENT_UNKNOWN)
2950     return MATCH_ERROR;
2951
2952   gfc_clear_attr (&current_attr);
2953   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2954
2955   return attr_decl ();
2956 }
2957
2958
2959 match
2960 gfc_match_intrinsic (void)
2961 {
2962
2963   gfc_clear_attr (&current_attr);
2964   gfc_add_intrinsic (&current_attr, NULL);
2965
2966   return attr_decl ();
2967 }
2968
2969
2970 match
2971 gfc_match_optional (void)
2972 {
2973
2974   gfc_clear_attr (&current_attr);
2975   gfc_add_optional (&current_attr, NULL);
2976
2977   return attr_decl ();
2978 }
2979
2980
2981 match
2982 gfc_match_pointer (void)
2983 {
2984
2985   gfc_clear_attr (&current_attr);
2986   gfc_add_pointer (&current_attr, NULL);
2987
2988   return attr_decl ();
2989 }
2990
2991
2992 match
2993 gfc_match_allocatable (void)
2994 {
2995
2996   gfc_clear_attr (&current_attr);
2997   gfc_add_allocatable (&current_attr, NULL);
2998
2999   return attr_decl ();
3000 }
3001
3002
3003 match
3004 gfc_match_dimension (void)
3005 {
3006
3007   gfc_clear_attr (&current_attr);
3008   gfc_add_dimension (&current_attr, NULL, NULL);
3009
3010   return attr_decl ();
3011 }
3012
3013
3014 match
3015 gfc_match_target (void)
3016 {
3017
3018   gfc_clear_attr (&current_attr);
3019   gfc_add_target (&current_attr, NULL);
3020
3021   return attr_decl ();
3022 }
3023
3024
3025 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3026    statement.  */
3027
3028 static match
3029 access_attr_decl (gfc_statement st)
3030 {
3031   char name[GFC_MAX_SYMBOL_LEN + 1];
3032   interface_type type;
3033   gfc_user_op *uop;
3034   gfc_symbol *sym;
3035   gfc_intrinsic_op operator;
3036   match m;
3037
3038   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3039     goto done;
3040
3041   for (;;)
3042     {
3043       m = gfc_match_generic_spec (&type, name, &operator);
3044       if (m == MATCH_NO)
3045         goto syntax;
3046       if (m == MATCH_ERROR)
3047         return MATCH_ERROR;
3048
3049       switch (type)
3050         {
3051         case INTERFACE_NAMELESS:
3052           goto syntax;
3053
3054         case INTERFACE_GENERIC:
3055           if (gfc_get_symbol (name, NULL, &sym))
3056             goto done;
3057
3058           if (gfc_add_access (&sym->attr,
3059                               (st ==
3060                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3061                               sym->name, NULL) == FAILURE)
3062             return MATCH_ERROR;
3063
3064           break;
3065
3066         case INTERFACE_INTRINSIC_OP:
3067           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3068             {
3069               gfc_current_ns->operator_access[operator] =
3070                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3071             }
3072           else
3073             {
3074               gfc_error ("Access specification of the %s operator at %C has "
3075                          "already been specified", gfc_op2string (operator));
3076               goto done;
3077             }
3078
3079           break;
3080
3081         case INTERFACE_USER_OP:
3082           uop = gfc_get_uop (name);
3083
3084           if (uop->access == ACCESS_UNKNOWN)
3085             {
3086               uop->access =
3087                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3088             }
3089           else
3090             {
3091               gfc_error
3092                 ("Access specification of the .%s. operator at %C has "
3093                  "already been specified", sym->name);
3094               goto done;
3095             }
3096
3097           break;
3098         }
3099
3100       if (gfc_match_char (',') == MATCH_NO)
3101         break;
3102     }
3103
3104   if (gfc_match_eos () != MATCH_YES)
3105     goto syntax;
3106   return MATCH_YES;
3107
3108 syntax:
3109   gfc_syntax_error (st);
3110
3111 done:
3112   return MATCH_ERROR;
3113 }
3114
3115
3116 /* The PRIVATE statement is a bit weird in that it can be a attribute
3117    declaration, but also works as a standlone statement inside of a
3118    type declaration or a module.  */
3119
3120 match
3121 gfc_match_private (gfc_statement * st)
3122 {
3123
3124   if (gfc_match ("private") != MATCH_YES)
3125     return MATCH_NO;
3126
3127   if (gfc_current_state () == COMP_DERIVED)
3128     {
3129       if (gfc_match_eos () == MATCH_YES)
3130         {
3131           *st = ST_PRIVATE;
3132           return MATCH_YES;
3133         }
3134
3135       gfc_syntax_error (ST_PRIVATE);
3136       return MATCH_ERROR;
3137     }
3138
3139   if (gfc_match_eos () == MATCH_YES)
3140     {
3141       *st = ST_PRIVATE;
3142       return MATCH_YES;
3143     }
3144
3145   *st = ST_ATTR_DECL;
3146   return access_attr_decl (ST_PRIVATE);
3147 }
3148
3149
3150 match
3151 gfc_match_public (gfc_statement * st)
3152 {
3153
3154   if (gfc_match ("public") != MATCH_YES)
3155     return MATCH_NO;
3156
3157   if (gfc_match_eos () == MATCH_YES)
3158     {
3159       *st = ST_PUBLIC;
3160       return MATCH_YES;
3161     }
3162
3163   *st = ST_ATTR_DECL;
3164   return access_attr_decl (ST_PUBLIC);
3165 }
3166
3167
3168 /* Workhorse for gfc_match_parameter.  */
3169
3170 static match
3171 do_parm (void)
3172 {
3173   gfc_symbol *sym;
3174   gfc_expr *init;
3175   match m;
3176
3177   m = gfc_match_symbol (&sym, 0);
3178   if (m == MATCH_NO)
3179     gfc_error ("Expected variable name at %C in PARAMETER statement");
3180
3181   if (m != MATCH_YES)
3182     return m;
3183
3184   if (gfc_match_char ('=') == MATCH_NO)
3185     {
3186       gfc_error ("Expected = sign in PARAMETER statement at %C");
3187       return MATCH_ERROR;
3188     }
3189
3190   m = gfc_match_init_expr (&init);
3191   if (m == MATCH_NO)
3192     gfc_error ("Expected expression at %C in PARAMETER statement");
3193   if (m != MATCH_YES)
3194     return m;
3195
3196   if (sym->ts.type == BT_UNKNOWN
3197       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3198     {
3199       m = MATCH_ERROR;
3200       goto cleanup;
3201     }
3202
3203   if (gfc_check_assign_symbol (sym, init) == FAILURE
3204       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3205     {
3206       m = MATCH_ERROR;
3207       goto cleanup;
3208     }
3209
3210   if (sym->ts.type == BT_CHARACTER
3211       && sym->ts.cl != NULL
3212       && sym->ts.cl->length != NULL
3213       && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3214       && init->expr_type == EXPR_CONSTANT
3215       && init->ts.type == BT_CHARACTER
3216       && init->ts.kind == 1)
3217     gfc_set_constant_character_len (
3218       mpz_get_si (sym->ts.cl->length->value.integer), init);
3219
3220   sym->value = init;
3221   return MATCH_YES;
3222
3223 cleanup:
3224   gfc_free_expr (init);
3225   return m;
3226 }
3227
3228
3229 /* Match a parameter statement, with the weird syntax that these have.  */
3230
3231 match
3232 gfc_match_parameter (void)
3233 {
3234   match m;
3235
3236   if (gfc_match_char ('(') == MATCH_NO)
3237     return MATCH_NO;
3238
3239   for (;;)
3240     {
3241       m = do_parm ();
3242       if (m != MATCH_YES)
3243         break;
3244
3245       if (gfc_match (" )%t") == MATCH_YES)
3246         break;
3247
3248       if (gfc_match_char (',') != MATCH_YES)
3249         {
3250           gfc_error ("Unexpected characters in PARAMETER statement at %C");
3251           m = MATCH_ERROR;
3252           break;
3253         }
3254     }
3255
3256   return m;
3257 }
3258
3259
3260 /* Save statements have a special syntax.  */
3261
3262 match
3263 gfc_match_save (void)
3264 {
3265   char n[GFC_MAX_SYMBOL_LEN+1];
3266   gfc_common_head *c;
3267   gfc_symbol *sym;
3268   match m;
3269
3270   if (gfc_match_eos () == MATCH_YES)
3271     {
3272       if (gfc_current_ns->seen_save)
3273         {
3274           if (gfc_notify_std (GFC_STD_LEGACY,
3275                               "Blanket SAVE statement at %C follows previous "
3276                               "SAVE statement")
3277               == FAILURE)
3278             return MATCH_ERROR;
3279         }
3280
3281       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3282       return MATCH_YES;
3283     }
3284
3285   if (gfc_current_ns->save_all)
3286     {
3287       if (gfc_notify_std (GFC_STD_LEGACY,
3288                           "SAVE statement at %C follows blanket SAVE statement")
3289           == FAILURE)
3290         return MATCH_ERROR;
3291     }
3292
3293   gfc_match (" ::");
3294
3295   for (;;)
3296     {
3297       m = gfc_match_symbol (&sym, 0);
3298       switch (m)
3299         {
3300         case MATCH_YES:
3301           if (gfc_add_save (&sym->attr, sym->name,
3302                             &gfc_current_locus) == FAILURE)
3303             return MATCH_ERROR;
3304           goto next_item;
3305
3306         case MATCH_NO:
3307           break;
3308
3309         case MATCH_ERROR:
3310           return MATCH_ERROR;
3311         }
3312
3313       m = gfc_match (" / %n /", &n);
3314       if (m == MATCH_ERROR)
3315         return MATCH_ERROR;
3316       if (m == MATCH_NO)
3317         goto syntax;
3318
3319       c = gfc_get_common (n, 0);
3320       c->saved = 1;
3321
3322       gfc_current_ns->seen_save = 1;
3323
3324     next_item:
3325       if (gfc_match_eos () == MATCH_YES)
3326         break;
3327       if (gfc_match_char (',') != MATCH_YES)
3328         goto syntax;
3329     }
3330
3331   return MATCH_YES;
3332
3333 syntax:
3334   gfc_error ("Syntax error in SAVE statement at %C");
3335   return MATCH_ERROR;
3336 }
3337
3338
3339 /* Match a module procedure statement.  Note that we have to modify
3340    symbols in the parent's namespace because the current one was there
3341    to receive symbols that are in an interface's formal argument list.  */
3342
3343 match
3344 gfc_match_modproc (void)
3345 {
3346   char name[GFC_MAX_SYMBOL_LEN + 1];
3347   gfc_symbol *sym;
3348   match m;
3349
3350   if (gfc_state_stack->state != COMP_INTERFACE
3351       || gfc_state_stack->previous == NULL
3352       || current_interface.type == INTERFACE_NAMELESS)
3353     {
3354       gfc_error
3355         ("MODULE PROCEDURE at %C must be in a generic module interface");
3356       return MATCH_ERROR;
3357     }
3358
3359   for (;;)
3360     {
3361       m = gfc_match_name (name);
3362       if (m == MATCH_NO)
3363         goto syntax;
3364       if (m != MATCH_YES)
3365         return MATCH_ERROR;
3366
3367       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3368         return MATCH_ERROR;
3369
3370       if (sym->attr.proc != PROC_MODULE
3371           && gfc_add_procedure (&sym->attr, PROC_MODULE,
3372                                 sym->name, NULL) == FAILURE)
3373         return MATCH_ERROR;
3374
3375       if (gfc_add_interface (sym) == FAILURE)
3376         return MATCH_ERROR;
3377
3378       if (gfc_match_eos () == MATCH_YES)
3379         break;
3380       if (gfc_match_char (',') != MATCH_YES)
3381         goto syntax;
3382     }
3383
3384   return MATCH_YES;
3385
3386 syntax:
3387   gfc_syntax_error (ST_MODULE_PROC);
3388   return MATCH_ERROR;
3389 }
3390
3391
3392 /* Match the beginning of a derived type declaration.  If a type name
3393    was the result of a function, then it is possible to have a symbol
3394    already to be known as a derived type yet have no components.  */
3395
3396 match
3397 gfc_match_derived_decl (void)
3398 {
3399   char name[GFC_MAX_SYMBOL_LEN + 1];
3400   symbol_attribute attr;
3401   gfc_symbol *sym;
3402   match m;
3403
3404   if (gfc_current_state () == COMP_DERIVED)
3405     return MATCH_NO;
3406
3407   gfc_clear_attr (&attr);
3408
3409 loop:
3410   if (gfc_match (" , private") == MATCH_YES)
3411     {
3412       if (gfc_find_state (COMP_MODULE) == FAILURE)
3413         {
3414           gfc_error
3415             ("Derived type at %C can only be PRIVATE within a MODULE");
3416           return MATCH_ERROR;
3417         }
3418
3419       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3420         return MATCH_ERROR;
3421       goto loop;
3422     }
3423
3424   if (gfc_match (" , public") == MATCH_YES)
3425     {
3426       if (gfc_find_state (COMP_MODULE) == FAILURE)
3427         {
3428           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3429           return MATCH_ERROR;
3430         }
3431
3432       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3433         return MATCH_ERROR;
3434       goto loop;
3435     }
3436
3437   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3438     {
3439       gfc_error ("Expected :: in TYPE definition at %C");
3440       return MATCH_ERROR;
3441     }
3442
3443   m = gfc_match (" %n%t", name);
3444   if (m != MATCH_YES)
3445     return m;
3446
3447   /* Make sure the name isn't the name of an intrinsic type.  The
3448      'double precision' type doesn't get past the name matcher.  */
3449   if (strcmp (name, "integer") == 0
3450       || strcmp (name, "real") == 0
3451       || strcmp (name, "character") == 0
3452       || strcmp (name, "logical") == 0
3453       || strcmp (name, "complex") == 0)
3454     {
3455       gfc_error
3456         ("Type name '%s' at %C cannot be the same as an intrinsic type",
3457          name);
3458       return MATCH_ERROR;
3459     }
3460
3461   if (gfc_get_symbol (name, NULL, &sym))
3462     return MATCH_ERROR;
3463
3464   if (sym->ts.type != BT_UNKNOWN)
3465     {
3466       gfc_error ("Derived type name '%s' at %C already has a basic type "
3467                  "of %s", sym->name, gfc_typename (&sym->ts));
3468       return MATCH_ERROR;
3469     }
3470
3471   /* The symbol may already have the derived attribute without the
3472      components.  The ways this can happen is via a function
3473      definition, an INTRINSIC statement or a subtype in another
3474      derived type that is a pointer.  The first part of the AND clause
3475      is true if a the symbol is not the return value of a function.  */
3476   if (sym->attr.flavor != FL_DERIVED
3477       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3478     return MATCH_ERROR;
3479
3480   if (sym->components != NULL)
3481     {
3482       gfc_error
3483         ("Derived type definition of '%s' at %C has already been defined",
3484          sym->name);
3485       return MATCH_ERROR;
3486     }
3487
3488   if (attr.access != ACCESS_UNKNOWN
3489       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3490     return MATCH_ERROR;
3491
3492   gfc_new_block = sym;
3493
3494   return MATCH_YES;
3495 }