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, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, 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, 0);
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 = proc->result;
2411
2412         }
2413       else
2414         {
2415           m = match_result (proc, &result);
2416           if (m == MATCH_NO)
2417             gfc_syntax_error (ST_ENTRY);
2418           if (m != MATCH_YES)
2419             return MATCH_ERROR;
2420
2421           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2422               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2423               || gfc_add_function (&entry->attr, result->name,
2424                                    NULL) == FAILURE)
2425             return MATCH_ERROR;
2426         }
2427
2428       if (proc->attr.recursive && result == NULL)
2429         {
2430           gfc_error ("RESULT attribute required in ENTRY statement at %C");
2431           return MATCH_ERROR;
2432         }
2433     }
2434
2435   if (gfc_match_eos () != MATCH_YES)
2436     {
2437       gfc_syntax_error (ST_ENTRY);
2438       return MATCH_ERROR;
2439     }
2440
2441   entry->attr.recursive = proc->attr.recursive;
2442   entry->attr.elemental = proc->attr.elemental;
2443   entry->attr.pure = proc->attr.pure;
2444
2445   el = gfc_get_entry_list ();
2446   el->sym = entry;
2447   el->next = gfc_current_ns->entries;
2448   gfc_current_ns->entries = el;
2449   if (el->next)
2450     el->id = el->next->id + 1;
2451   else
2452     el->id = 1;
2453
2454   new_st.op = EXEC_ENTRY;
2455   new_st.ext.entry = el;
2456
2457   return MATCH_YES;
2458 }
2459
2460
2461 /* Match a subroutine statement, including optional prefixes.  */
2462
2463 match
2464 gfc_match_subroutine (void)
2465 {
2466   char name[GFC_MAX_SYMBOL_LEN + 1];
2467   gfc_symbol *sym;
2468   match m;
2469
2470   if (gfc_current_state () != COMP_NONE
2471       && gfc_current_state () != COMP_INTERFACE
2472       && gfc_current_state () != COMP_CONTAINS)
2473     return MATCH_NO;
2474
2475   m = match_prefix (NULL);
2476   if (m != MATCH_YES)
2477     return m;
2478
2479   m = gfc_match ("subroutine% %n", name);
2480   if (m != MATCH_YES)
2481     return m;
2482
2483   if (get_proc_name (name, &sym))
2484     return MATCH_ERROR;
2485   gfc_new_block = sym;
2486
2487   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2488     return MATCH_ERROR;
2489
2490   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2491     return MATCH_ERROR;
2492
2493   if (gfc_match_eos () != MATCH_YES)
2494     {
2495       gfc_syntax_error (ST_SUBROUTINE);
2496       return MATCH_ERROR;
2497     }
2498
2499   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2500     return MATCH_ERROR;
2501
2502   return MATCH_YES;
2503 }
2504
2505
2506 /* Return nonzero if we're currently compiling a contained procedure.  */
2507
2508 static int
2509 contained_procedure (void)
2510 {
2511   gfc_state_data *s;
2512
2513   for (s=gfc_state_stack; s; s=s->previous)
2514     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2515        && s->previous != NULL
2516        && s->previous->state == COMP_CONTAINS)
2517       return 1;
2518
2519   return 0;
2520 }
2521
2522 /* Match any of the various end-block statements.  Returns the type of
2523    END to the caller.  The END INTERFACE, END IF, END DO and END
2524    SELECT statements cannot be replaced by a single END statement.  */
2525
2526 match
2527 gfc_match_end (gfc_statement * st)
2528 {
2529   char name[GFC_MAX_SYMBOL_LEN + 1];
2530   gfc_compile_state state;
2531   locus old_loc;
2532   const char *block_name;
2533   const char *target;
2534   int eos_ok;
2535   match m;
2536
2537   old_loc = gfc_current_locus;
2538   if (gfc_match ("end") != MATCH_YES)
2539     return MATCH_NO;
2540
2541   state = gfc_current_state ();
2542   block_name =
2543     gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2544
2545   if (state == COMP_CONTAINS)
2546     {
2547       state = gfc_state_stack->previous->state;
2548       block_name = gfc_state_stack->previous->sym == NULL ? NULL
2549         : gfc_state_stack->previous->sym->name;
2550     }
2551
2552   switch (state)
2553     {
2554     case COMP_NONE:
2555     case COMP_PROGRAM:
2556       *st = ST_END_PROGRAM;
2557       target = " program";
2558       eos_ok = 1;
2559       break;
2560
2561     case COMP_SUBROUTINE:
2562       *st = ST_END_SUBROUTINE;
2563       target = " subroutine";
2564       eos_ok = !contained_procedure ();
2565       break;
2566
2567     case COMP_FUNCTION:
2568       *st = ST_END_FUNCTION;
2569       target = " function";
2570       eos_ok = !contained_procedure ();
2571       break;
2572
2573     case COMP_BLOCK_DATA:
2574       *st = ST_END_BLOCK_DATA;
2575       target = " block data";
2576       eos_ok = 1;
2577       break;
2578
2579     case COMP_MODULE:
2580       *st = ST_END_MODULE;
2581       target = " module";
2582       eos_ok = 1;
2583       break;
2584
2585     case COMP_INTERFACE:
2586       *st = ST_END_INTERFACE;
2587       target = " interface";
2588       eos_ok = 0;
2589       break;
2590
2591     case COMP_DERIVED:
2592       *st = ST_END_TYPE;
2593       target = " type";
2594       eos_ok = 0;
2595       break;
2596
2597     case COMP_IF:
2598       *st = ST_ENDIF;
2599       target = " if";
2600       eos_ok = 0;
2601       break;
2602
2603     case COMP_DO:
2604       *st = ST_ENDDO;
2605       target = " do";
2606       eos_ok = 0;
2607       break;
2608
2609     case COMP_SELECT:
2610       *st = ST_END_SELECT;
2611       target = " select";
2612       eos_ok = 0;
2613       break;
2614
2615     case COMP_FORALL:
2616       *st = ST_END_FORALL;
2617       target = " forall";
2618       eos_ok = 0;
2619       break;
2620
2621     case COMP_WHERE:
2622       *st = ST_END_WHERE;
2623       target = " where";
2624       eos_ok = 0;
2625       break;
2626
2627     default:
2628       gfc_error ("Unexpected END statement at %C");
2629       goto cleanup;
2630     }
2631
2632   if (gfc_match_eos () == MATCH_YES)
2633     {
2634       if (!eos_ok)
2635         {
2636           /* We would have required END [something]  */
2637           gfc_error ("%s statement expected at %L",
2638                      gfc_ascii_statement (*st), &old_loc);
2639           goto cleanup;
2640         }
2641
2642       return MATCH_YES;
2643     }
2644
2645   /* Verify that we've got the sort of end-block that we're expecting.  */
2646   if (gfc_match (target) != MATCH_YES)
2647     {
2648       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
2649       goto cleanup;
2650     }
2651
2652   /* If we're at the end, make sure a block name wasn't required.  */
2653   if (gfc_match_eos () == MATCH_YES)
2654     {
2655
2656       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
2657         return MATCH_YES;
2658
2659       if (gfc_current_block () == NULL)
2660         return MATCH_YES;
2661
2662       gfc_error ("Expected block name of '%s' in %s statement at %C",
2663                  block_name, gfc_ascii_statement (*st));
2664
2665       return MATCH_ERROR;
2666     }
2667
2668   /* END INTERFACE has a special handler for its several possible endings.  */
2669   if (*st == ST_END_INTERFACE)
2670     return gfc_match_end_interface ();
2671
2672   /* We haven't hit the end of statement, so what is left must be an end-name.  */
2673   m = gfc_match_space ();
2674   if (m == MATCH_YES)
2675     m = gfc_match_name (name);
2676
2677   if (m == MATCH_NO)
2678     gfc_error ("Expected terminating name at %C");
2679   if (m != MATCH_YES)
2680     goto cleanup;
2681
2682   if (block_name == NULL)
2683     goto syntax;
2684
2685   if (strcmp (name, block_name) != 0)
2686     {
2687       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
2688                  gfc_ascii_statement (*st));
2689       goto cleanup;
2690     }
2691
2692   if (gfc_match_eos () == MATCH_YES)
2693     return MATCH_YES;
2694
2695 syntax:
2696   gfc_syntax_error (*st);
2697
2698 cleanup:
2699   gfc_current_locus = old_loc;
2700   return MATCH_ERROR;
2701 }
2702
2703
2704
2705 /***************** Attribute declaration statements ****************/
2706
2707 /* Set the attribute of a single variable.  */
2708
2709 static match
2710 attr_decl1 (void)
2711 {
2712   char name[GFC_MAX_SYMBOL_LEN + 1];
2713   gfc_array_spec *as;
2714   gfc_symbol *sym;
2715   locus var_locus;
2716   match m;
2717
2718   as = NULL;
2719
2720   m = gfc_match_name (name);
2721   if (m != MATCH_YES)
2722     goto cleanup;
2723
2724   if (find_special (name, &sym))
2725     return MATCH_ERROR;
2726
2727   var_locus = gfc_current_locus;
2728
2729   /* Deal with possible array specification for certain attributes.  */
2730   if (current_attr.dimension
2731       || current_attr.allocatable
2732       || current_attr.pointer
2733       || current_attr.target)
2734     {
2735       m = gfc_match_array_spec (&as);
2736       if (m == MATCH_ERROR)
2737         goto cleanup;
2738
2739       if (current_attr.dimension && m == MATCH_NO)
2740         {
2741           gfc_error
2742             ("Missing array specification at %L in DIMENSION statement",
2743              &var_locus);
2744           m = MATCH_ERROR;
2745           goto cleanup;
2746         }
2747
2748       if ((current_attr.allocatable || current_attr.pointer)
2749           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2750         {
2751           gfc_error ("Array specification must be deferred at %L",
2752                      &var_locus);
2753           m = MATCH_ERROR;
2754           goto cleanup;
2755         }
2756     }
2757
2758   /* Update symbol table.  DIMENSION attribute is set in gfc_set_array_spec().  */
2759   if (current_attr.dimension == 0
2760       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2761     {
2762       m = MATCH_ERROR;
2763       goto cleanup;
2764     }
2765
2766   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2767     {
2768       m = MATCH_ERROR;
2769       goto cleanup;
2770     }
2771
2772   if ((current_attr.external || current_attr.intrinsic)
2773       && sym->attr.flavor != FL_PROCEDURE
2774       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
2775     {
2776       m = MATCH_ERROR;
2777       goto cleanup;
2778     }
2779
2780   return MATCH_YES;
2781
2782 cleanup:
2783   gfc_free_array_spec (as);
2784   return m;
2785 }
2786
2787
2788 /* Generic attribute declaration subroutine.  Used for attributes that
2789    just have a list of names.  */
2790
2791 static match
2792 attr_decl (void)
2793 {
2794   match m;
2795
2796   /* Gobble the optional double colon, by simply ignoring the result
2797      of gfc_match().  */
2798   gfc_match (" ::");
2799
2800   for (;;)
2801     {
2802       m = attr_decl1 ();
2803       if (m != MATCH_YES)
2804         break;
2805
2806       if (gfc_match_eos () == MATCH_YES)
2807         {
2808           m = MATCH_YES;
2809           break;
2810         }
2811
2812       if (gfc_match_char (',') != MATCH_YES)
2813         {
2814           gfc_error ("Unexpected character in variable list at %C");
2815           m = MATCH_ERROR;
2816           break;
2817         }
2818     }
2819
2820   return m;
2821 }
2822
2823
2824 match
2825 gfc_match_external (void)
2826 {
2827
2828   gfc_clear_attr (&current_attr);
2829   gfc_add_external (&current_attr, NULL);
2830
2831   return attr_decl ();
2832 }
2833
2834
2835
2836 match
2837 gfc_match_intent (void)
2838 {
2839   sym_intent intent;
2840
2841   intent = match_intent_spec ();
2842   if (intent == INTENT_UNKNOWN)
2843     return MATCH_ERROR;
2844
2845   gfc_clear_attr (&current_attr);
2846   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2847
2848   return attr_decl ();
2849 }
2850
2851
2852 match
2853 gfc_match_intrinsic (void)
2854 {
2855
2856   gfc_clear_attr (&current_attr);
2857   gfc_add_intrinsic (&current_attr, NULL);
2858
2859   return attr_decl ();
2860 }
2861
2862
2863 match
2864 gfc_match_optional (void)
2865 {
2866
2867   gfc_clear_attr (&current_attr);
2868   gfc_add_optional (&current_attr, NULL);
2869
2870   return attr_decl ();
2871 }
2872
2873
2874 match
2875 gfc_match_pointer (void)
2876 {
2877
2878   gfc_clear_attr (&current_attr);
2879   gfc_add_pointer (&current_attr, NULL);
2880
2881   return attr_decl ();
2882 }
2883
2884
2885 match
2886 gfc_match_allocatable (void)
2887 {
2888
2889   gfc_clear_attr (&current_attr);
2890   gfc_add_allocatable (&current_attr, NULL);
2891
2892   return attr_decl ();
2893 }
2894
2895
2896 match
2897 gfc_match_dimension (void)
2898 {
2899
2900   gfc_clear_attr (&current_attr);
2901   gfc_add_dimension (&current_attr, NULL, NULL);
2902
2903   return attr_decl ();
2904 }
2905
2906
2907 match
2908 gfc_match_target (void)
2909 {
2910
2911   gfc_clear_attr (&current_attr);
2912   gfc_add_target (&current_attr, NULL);
2913
2914   return attr_decl ();
2915 }
2916
2917
2918 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2919    statement.  */
2920
2921 static match
2922 access_attr_decl (gfc_statement st)
2923 {
2924   char name[GFC_MAX_SYMBOL_LEN + 1];
2925   interface_type type;
2926   gfc_user_op *uop;
2927   gfc_symbol *sym;
2928   gfc_intrinsic_op operator;
2929   match m;
2930
2931   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2932     goto done;
2933
2934   for (;;)
2935     {
2936       m = gfc_match_generic_spec (&type, name, &operator);
2937       if (m == MATCH_NO)
2938         goto syntax;
2939       if (m == MATCH_ERROR)
2940         return MATCH_ERROR;
2941
2942       switch (type)
2943         {
2944         case INTERFACE_NAMELESS:
2945           goto syntax;
2946
2947         case INTERFACE_GENERIC:
2948           if (gfc_get_symbol (name, NULL, &sym))
2949             goto done;
2950
2951           if (gfc_add_access (&sym->attr,
2952                               (st ==
2953                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2954                               sym->name, NULL) == FAILURE)
2955             return MATCH_ERROR;
2956
2957           break;
2958
2959         case INTERFACE_INTRINSIC_OP:
2960           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2961             {
2962               gfc_current_ns->operator_access[operator] =
2963                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2964             }
2965           else
2966             {
2967               gfc_error ("Access specification of the %s operator at %C has "
2968                          "already been specified", gfc_op2string (operator));
2969               goto done;
2970             }
2971
2972           break;
2973
2974         case INTERFACE_USER_OP:
2975           uop = gfc_get_uop (name);
2976
2977           if (uop->access == ACCESS_UNKNOWN)
2978             {
2979               uop->access =
2980                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2981             }
2982           else
2983             {
2984               gfc_error
2985                 ("Access specification of the .%s. operator at %C has "
2986                  "already been specified", sym->name);
2987               goto done;
2988             }
2989
2990           break;
2991         }
2992
2993       if (gfc_match_char (',') == MATCH_NO)
2994         break;
2995     }
2996
2997   if (gfc_match_eos () != MATCH_YES)
2998     goto syntax;
2999   return MATCH_YES;
3000
3001 syntax:
3002   gfc_syntax_error (st);
3003
3004 done:
3005   return MATCH_ERROR;
3006 }
3007
3008
3009 /* The PRIVATE statement is a bit weird in that it can be a attribute
3010    declaration, but also works as a standlone statement inside of a
3011    type declaration or a module.  */
3012
3013 match
3014 gfc_match_private (gfc_statement * st)
3015 {
3016
3017   if (gfc_match ("private") != MATCH_YES)
3018     return MATCH_NO;
3019
3020   if (gfc_current_state () == COMP_DERIVED)
3021     {
3022       if (gfc_match_eos () == MATCH_YES)
3023         {
3024           *st = ST_PRIVATE;
3025           return MATCH_YES;
3026         }
3027
3028       gfc_syntax_error (ST_PRIVATE);
3029       return MATCH_ERROR;
3030     }
3031
3032   if (gfc_match_eos () == MATCH_YES)
3033     {
3034       *st = ST_PRIVATE;
3035       return MATCH_YES;
3036     }
3037
3038   *st = ST_ATTR_DECL;
3039   return access_attr_decl (ST_PRIVATE);
3040 }
3041
3042
3043 match
3044 gfc_match_public (gfc_statement * st)
3045 {
3046
3047   if (gfc_match ("public") != MATCH_YES)
3048     return MATCH_NO;
3049
3050   if (gfc_match_eos () == MATCH_YES)
3051     {
3052       *st = ST_PUBLIC;
3053       return MATCH_YES;
3054     }
3055
3056   *st = ST_ATTR_DECL;
3057   return access_attr_decl (ST_PUBLIC);
3058 }
3059
3060
3061 /* Workhorse for gfc_match_parameter.  */
3062
3063 static match
3064 do_parm (void)
3065 {
3066   gfc_symbol *sym;
3067   gfc_expr *init;
3068   match m;
3069
3070   m = gfc_match_symbol (&sym, 0);
3071   if (m == MATCH_NO)
3072     gfc_error ("Expected variable name at %C in PARAMETER statement");
3073
3074   if (m != MATCH_YES)
3075     return m;
3076
3077   if (gfc_match_char ('=') == MATCH_NO)
3078     {
3079       gfc_error ("Expected = sign in PARAMETER statement at %C");
3080       return MATCH_ERROR;
3081     }
3082
3083   m = gfc_match_init_expr (&init);
3084   if (m == MATCH_NO)
3085     gfc_error ("Expected expression at %C in PARAMETER statement");
3086   if (m != MATCH_YES)
3087     return m;
3088
3089   if (sym->ts.type == BT_UNKNOWN
3090       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3091     {
3092       m = MATCH_ERROR;
3093       goto cleanup;
3094     }
3095
3096   if (gfc_check_assign_symbol (sym, init) == FAILURE
3097       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3098     {
3099       m = MATCH_ERROR;
3100       goto cleanup;
3101     }
3102
3103   sym->value = init;
3104   return MATCH_YES;
3105
3106 cleanup:
3107   gfc_free_expr (init);
3108   return m;
3109 }
3110
3111
3112 /* Match a parameter statement, with the weird syntax that these have.  */
3113
3114 match
3115 gfc_match_parameter (void)
3116 {
3117   match m;
3118
3119   if (gfc_match_char ('(') == MATCH_NO)
3120     return MATCH_NO;
3121
3122   for (;;)
3123     {
3124       m = do_parm ();
3125       if (m != MATCH_YES)
3126         break;
3127
3128       if (gfc_match (" )%t") == MATCH_YES)
3129         break;
3130
3131       if (gfc_match_char (',') != MATCH_YES)
3132         {
3133           gfc_error ("Unexpected characters in PARAMETER statement at %C");
3134           m = MATCH_ERROR;
3135           break;
3136         }
3137     }
3138
3139   return m;
3140 }
3141
3142
3143 /* Save statements have a special syntax.  */
3144
3145 match
3146 gfc_match_save (void)
3147 {
3148   char n[GFC_MAX_SYMBOL_LEN+1];
3149   gfc_common_head *c;
3150   gfc_symbol *sym;
3151   match m;
3152
3153   if (gfc_match_eos () == MATCH_YES)
3154     {
3155       if (gfc_current_ns->seen_save)
3156         {
3157           gfc_error ("Blanket SAVE statement at %C follows previous "
3158                      "SAVE statement");
3159
3160           return MATCH_ERROR;
3161         }
3162
3163       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3164       return MATCH_YES;
3165     }
3166
3167   if (gfc_current_ns->save_all)
3168     {
3169       gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3170       return MATCH_ERROR;
3171     }
3172
3173   gfc_match (" ::");
3174
3175   for (;;)
3176     {
3177       m = gfc_match_symbol (&sym, 0);
3178       switch (m)
3179         {
3180         case MATCH_YES:
3181           if (gfc_add_save (&sym->attr, sym->name,
3182                             &gfc_current_locus) == FAILURE)
3183             return MATCH_ERROR;
3184           goto next_item;
3185
3186         case MATCH_NO:
3187           break;
3188
3189         case MATCH_ERROR:
3190           return MATCH_ERROR;
3191         }
3192
3193       m = gfc_match (" / %n /", &n);
3194       if (m == MATCH_ERROR)
3195         return MATCH_ERROR;
3196       if (m == MATCH_NO)
3197         goto syntax;
3198
3199       c = gfc_get_common (n, 0);
3200       c->saved = 1;
3201
3202       gfc_current_ns->seen_save = 1;
3203
3204     next_item:
3205       if (gfc_match_eos () == MATCH_YES)
3206         break;
3207       if (gfc_match_char (',') != MATCH_YES)
3208         goto syntax;
3209     }
3210
3211   return MATCH_YES;
3212
3213 syntax:
3214   gfc_error ("Syntax error in SAVE statement at %C");
3215   return MATCH_ERROR;
3216 }
3217
3218
3219 /* Match a module procedure statement.  Note that we have to modify
3220    symbols in the parent's namespace because the current one was there
3221    to receive symbols that are in a interface's formal argument list.  */
3222
3223 match
3224 gfc_match_modproc (void)
3225 {
3226   char name[GFC_MAX_SYMBOL_LEN + 1];
3227   gfc_symbol *sym;
3228   match m;
3229
3230   if (gfc_state_stack->state != COMP_INTERFACE
3231       || gfc_state_stack->previous == NULL
3232       || current_interface.type == INTERFACE_NAMELESS)
3233     {
3234       gfc_error
3235         ("MODULE PROCEDURE at %C must be in a generic module interface");
3236       return MATCH_ERROR;
3237     }
3238
3239   for (;;)
3240     {
3241       m = gfc_match_name (name);
3242       if (m == MATCH_NO)
3243         goto syntax;
3244       if (m != MATCH_YES)
3245         return MATCH_ERROR;
3246
3247       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3248         return MATCH_ERROR;
3249
3250       if (sym->attr.proc != PROC_MODULE
3251           && gfc_add_procedure (&sym->attr, PROC_MODULE,
3252                                 sym->name, NULL) == FAILURE)
3253         return MATCH_ERROR;
3254
3255       if (gfc_add_interface (sym) == FAILURE)
3256         return MATCH_ERROR;
3257
3258       if (gfc_match_eos () == MATCH_YES)
3259         break;
3260       if (gfc_match_char (',') != MATCH_YES)
3261         goto syntax;
3262     }
3263
3264   return MATCH_YES;
3265
3266 syntax:
3267   gfc_syntax_error (ST_MODULE_PROC);
3268   return MATCH_ERROR;
3269 }
3270
3271
3272 /* Match the beginning of a derived type declaration.  If a type name
3273    was the result of a function, then it is possible to have a symbol
3274    already to be known as a derived type yet have no components.  */
3275
3276 match
3277 gfc_match_derived_decl (void)
3278 {
3279   char name[GFC_MAX_SYMBOL_LEN + 1];
3280   symbol_attribute attr;
3281   gfc_symbol *sym;
3282   match m;
3283
3284   if (gfc_current_state () == COMP_DERIVED)
3285     return MATCH_NO;
3286
3287   gfc_clear_attr (&attr);
3288
3289 loop:
3290   if (gfc_match (" , private") == MATCH_YES)
3291     {
3292       if (gfc_find_state (COMP_MODULE) == FAILURE)
3293         {
3294           gfc_error
3295             ("Derived type at %C can only be PRIVATE within a MODULE");
3296           return MATCH_ERROR;
3297         }
3298
3299       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3300         return MATCH_ERROR;
3301       goto loop;
3302     }
3303
3304   if (gfc_match (" , public") == MATCH_YES)
3305     {
3306       if (gfc_find_state (COMP_MODULE) == FAILURE)
3307         {
3308           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3309           return MATCH_ERROR;
3310         }
3311
3312       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3313         return MATCH_ERROR;
3314       goto loop;
3315     }
3316
3317   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3318     {
3319       gfc_error ("Expected :: in TYPE definition at %C");
3320       return MATCH_ERROR;
3321     }
3322
3323   m = gfc_match (" %n%t", name);
3324   if (m != MATCH_YES)
3325     return m;
3326
3327   /* Make sure the name isn't the name of an intrinsic type.  The
3328      'double precision' type doesn't get past the name matcher.  */
3329   if (strcmp (name, "integer") == 0
3330       || strcmp (name, "real") == 0
3331       || strcmp (name, "character") == 0
3332       || strcmp (name, "logical") == 0
3333       || strcmp (name, "complex") == 0)
3334     {
3335       gfc_error
3336         ("Type name '%s' at %C cannot be the same as an intrinsic type",
3337          name);
3338       return MATCH_ERROR;
3339     }
3340
3341   if (gfc_get_symbol (name, NULL, &sym))
3342     return MATCH_ERROR;
3343
3344   if (sym->ts.type != BT_UNKNOWN)
3345     {
3346       gfc_error ("Derived type name '%s' at %C already has a basic type "
3347                  "of %s", sym->name, gfc_typename (&sym->ts));
3348       return MATCH_ERROR;
3349     }
3350
3351   /* The symbol may already have the derived attribute without the
3352      components.  The ways this can happen is via a function
3353      definition, an INTRINSIC statement or a subtype in another
3354      derived type that is a pointer.  The first part of the AND clause
3355      is true if a the symbol is not the return value of a function.  */
3356   if (sym->attr.flavor != FL_DERIVED
3357       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3358     return MATCH_ERROR;
3359
3360   if (sym->components != NULL)
3361     {
3362       gfc_error
3363         ("Derived type definition of '%s' at %C has already been defined",
3364          sym->name);
3365       return MATCH_ERROR;
3366     }
3367
3368   if (attr.access != ACCESS_UNKNOWN
3369       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3370     return MATCH_ERROR;
3371
3372   gfc_new_block = sym;
3373
3374   return MATCH_YES;
3375 }