gcc/fortran/decl.c

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