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