gcc/fortran/decl.c

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