gcc/fortran/decl.c

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