gcc/fortran/decl.c

   1 /* Declaration statement matcher
   2    Copyright (C) 2002 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22
  23 #include "config.h"
  24 #include "gfortran.h"
  25 #include "match.h"
  26 #include "parse.h"
  27 #include <string.h>
  28
  29
  30 /* This flag is set if a an old-style length selector is matched
  31    during a type-declaration statement.  */
  32
  33 static int old_char_selector;
  34
  35 /* When variables aquire types and attributes from a declaration
  36    statement, they get them from the following static variables.  The
  37    first part of a declaration sets these variables and the second
  38    part copies these into symbol structures.  */
  39
  40 static gfc_typespec current_ts;
  41
  42 static symbol_attribute current_attr;
  43 static gfc_array_spec *current_as;
  44 static int colon_seen;
  45
  46 /* gfc_new_block points to the symbol of a newly matched block.  */
  47
  48 gfc_symbol *gfc_new_block;
  49
  50
  51 /* Match an intent specification.  Since this can only happen after an
  52    INTENT word, a legal intent-spec must follow.  */
  53
  54 static sym_intent
  55 match_intent_spec (void)
  56 {
  57
  58   if (gfc_match (" ( in out )") == MATCH_YES)
  59     return INTENT_INOUT;
  60   if (gfc_match (" ( in )") == MATCH_YES)
  61     return INTENT_IN;
  62   if (gfc_match (" ( out )") == MATCH_YES)
  63     return INTENT_OUT;
  64
  65   gfc_error ("Bad INTENT specification at %C");
  66   return INTENT_UNKNOWN;
  67 }
  68
  69
  70 /* Matches a character length specification, which is either a
  71    specification expression or a '*'.  */
  72
  73 static match
  74 char_len_param_value (gfc_expr ** expr)
  75 {
  76
  77   if (gfc_match_char ('*') == MATCH_YES)
  78     {
  79       *expr = NULL;
  80       return MATCH_YES;
  81     }
  82
  83   return gfc_match_expr (expr);
  84 }
  85
  86
  87 /* A character length is a '*' followed by a literal integer or a
  88    char_len_param_value in parenthesis.  */
  89
  90 static match
  91 match_char_length (gfc_expr ** expr)
  92 {
  93   int length;
  94   match m;
  95
  96   m = gfc_match_char ('*');
  97   if (m != MATCH_YES)
  98     return m;
  99
 100   m = gfc_match_small_literal_int (&length);
 101   if (m == MATCH_ERROR)
 102     return m;
 103
 104   if (m == MATCH_YES)
 105     {
 106       *expr = gfc_int_expr (length);
 107       return m;
 108     }
 109
 110   if (gfc_match_char ('(') == MATCH_NO)
 111     goto syntax;
 112
 113   m = char_len_param_value (expr);
 114   if (m == MATCH_ERROR)
 115     return m;
 116   if (m == MATCH_NO)
 117     goto syntax;
 118
 119   if (gfc_match_char (')') == MATCH_NO)
 120     {
 121       gfc_free_expr (*expr);
 122       *expr = NULL;
 123       goto syntax;
 124     }
 125
 126   return MATCH_YES;
 127
 128 syntax:
 129   gfc_error ("Syntax error in character length specification at %C");
 130   return MATCH_ERROR;
 131 }
 132
 133
 134 /* Special subroutine for finding a symbol.  If we're compiling a
 135    function or subroutine and the parent compilation unit is an
 136    interface, then check to see if the name we've been given is the
 137    name of the interface (located in another namespace).  If so,
 138    return that symbol.  If not, use gfc_get_symbol().  */
 139
 140 static int
 141 find_special (const char *name, gfc_symbol ** result)
 142 {
 143   gfc_state_data *s;
 144
 145   if (gfc_current_state () != COMP_SUBROUTINE
 146       && gfc_current_state () != COMP_FUNCTION)
 147     goto normal;
 148
 149   s = gfc_state_stack->previous;
 150   if (s == NULL)
 151     goto normal;
 152
 153   if (s->state != COMP_INTERFACE)
 154     goto normal;
 155   if (s->sym == NULL)
 156     goto normal;                /* Nameless interface */
 157
 158   if (strcmp (name, s->sym->name) == 0)
 159     {
 160       *result = s->sym;
 161       return 0;
 162     }
 163
 164 normal:
 165   return gfc_get_symbol (name, NULL, result);
 166 }
 167
 168
 169 /* Special subroutine for getting a symbol node associated with a
 170    procedure name, used in SUBROUTINE and FUNCTION statements.  The
 171    symbol is created in the parent using with symtree node in the
 172    child unit pointing to the symbol.  If the current namespace has no
 173    parent, then the symbol is just created in the current unit.  */
 174
 175 static int
 176 get_proc_name (const char *name, gfc_symbol ** result)
 177 {
 178   gfc_symtree *st;
 179   gfc_symbol *sym;
 180   int rc;
 181
 182   if (gfc_current_ns->parent == NULL)
 183     return gfc_get_symbol (name, NULL, result);
 184
 185   rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
 186   if (*result == NULL)
 187     return rc;
 188
 189   /* Deal with ENTRY problem */
 190
 191   st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 192
 193   sym = *result;
 194   st->n.sym = sym;
 195   sym->refs++;
 196
 197   /* See if the procedure should be a module procedure */
 198
 199   if (sym->ns->proc_name != NULL
 200       && sym->ns->proc_name->attr.flavor == FL_MODULE
 201       && sym->attr.proc != PROC_MODULE
 202       && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
 203     rc = 2;
 204
 205   return rc;
 206 }
 207
 208
 209 /* Function called by variable_decl() that adds a name to the symbol
 210    table.  */
 211
 212 static try
 213 build_sym (const char *name, gfc_charlen * cl,
 214            gfc_array_spec ** as, locus * var_locus)
 215 {
 216   symbol_attribute attr;
 217   gfc_symbol *sym;
 218
 219   if (find_special (name, &sym))
 220     return FAILURE;
 221
 222   /* Start updating the symbol table.  Add basic type attribute
 223      if present.  */
 224   if (current_ts.type != BT_UNKNOWN
 225       &&(sym->attr.implicit_type == 0
 226          || !gfc_compare_types (&sym->ts, &current_ts))
 227       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
 228     return FAILURE;
 229
 230   if (sym->ts.type == BT_CHARACTER)
 231     sym->ts.cl = cl;
 232
 233   /* Add dimension attribute if present.  */
 234   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
 235     return FAILURE;
 236   *as = NULL;
 237
 238   /* Add attribute to symbol.  The copy is so that we can reset the
 239      dimension attribute.  */
 240   attr = current_attr;
 241   attr.dimension = 0;
 242
 243   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
 244     return FAILURE;
 245
 246   return SUCCESS;
 247 }
 248
 249
 250 /* Function called by variable_decl() that adds an initialization
 251    expression to a symbol.  */
 252
 253 static try
 254 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
 255                       locus * var_locus)
 256 {
 257   symbol_attribute attr;
 258   gfc_symbol *sym;
 259   gfc_expr *init;
 260
 261   init = *initp;
 262   if (find_special (name, &sym))
 263     return FAILURE;
 264
 265   attr = sym->attr;
 266
 267   /* If this symbol is confirming an implicit parameter type,
 268      then an initialization expression is not allowed.  */
 269   if (attr.flavor == FL_PARAMETER
 270       && sym->value != NULL
 271       && *initp != NULL)
 272     {
 273       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
 274                  sym->name);
 275       return FAILURE;
 276     }
 277
 278   if (attr.in_common
 279       && !attr.data
 280       && *initp != NULL)
 281     {
 282       gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
 283                  sym->name);
 284       return FAILURE;
 285     }
 286
 287   if (init == NULL)
 288     {
 289       /* An initializer is required for PARAMETER declarations.  */
 290       if (attr.flavor == FL_PARAMETER)
 291         {
 292           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
 293           return FAILURE;
 294         }
 295     }
 296   else
 297     {
 298       /* If a variable appears in a DATA block, it cannot have an
 299          initializer.  */
 300       if (sym->attr.data)
 301         {
 302           gfc_error
 303             ("Variable '%s' at %C with an initializer already appears "
 304              "in a DATA statement", sym->name);
 305           return FAILURE;
 306         }
 307
 308       /* Checking a derived type parameter has to be put off until later.  */
 309       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
 310           && gfc_check_assign_symbol (sym, init) == FAILURE)
 311         return FAILURE;
 312
 313       /* Add initializer.  Make sure we keep the ranks sane.  */
 314       if (sym->attr.dimension && init->rank == 0)
 315         init->rank = sym->as->rank;
 316
 317       sym->value = init;
 318       *initp = NULL;
 319     }
 320
 321   return SUCCESS;
 322 }
 323
 324
 325 /* Function called by variable_decl() that adds a name to a structure
 326    being built.  */
 327
 328 static try
 329 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
 330               gfc_array_spec ** as)
 331 {
 332   gfc_component *c;
 333
 334   /* If the current symbol is of the same derived type that we're
 335      constructing, it must have the pointer attribute.  */
 336   if (current_ts.type == BT_DERIVED
 337       && current_ts.derived == gfc_current_block ()
 338       && current_attr.pointer == 0)
 339     {
 340       gfc_error ("Component at %C must have the POINTER attribute");
 341       return FAILURE;
 342     }
 343
 344   if (gfc_current_block ()->attr.pointer
 345       && (*as)->rank != 0)
 346     {
 347       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
 348         {
 349           gfc_error ("Array component of structure at %C must have explicit "
 350                      "or deferred shape");
 351           return FAILURE;
 352         }
 353     }
 354
 355   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
 356     return FAILURE;
 357
 358   c->ts = current_ts;
 359   c->ts.cl = cl;
 360   gfc_set_component_attr (c, &current_attr);
 361
 362   c->initializer = *init;
 363   *init = NULL;
 364
 365   c->as = *as;
 366   if (c->as != NULL)
 367     c->dimension = 1;
 368   *as = NULL;
 369
 370   /* Check array components.  */
 371   if (!c->dimension)
 372     return SUCCESS;
 373
 374   if (c->pointer)
 375     {
 376       if (c->as->type != AS_DEFERRED)
 377         {
 378           gfc_error ("Pointer array component of structure at %C "
 379                      "must have a deferred shape");
 380           return FAILURE;
 381         }
 382     }
 383   else
 384     {
 385       if (c->as->type != AS_EXPLICIT)
 386         {
 387           gfc_error
 388             ("Array component of structure at %C must have an explicit "
 389              "shape");
 390           return FAILURE;
 391         }
 392     }
 393
 394   return SUCCESS;
 395 }
 396
 397
 398 /* Match a 'NULL()', and possibly take care of some side effects.  */
 399
 400 match
 401 gfc_match_null (gfc_expr ** result)
 402 {
 403   gfc_symbol *sym;
 404   gfc_expr *e;
 405   match m;
 406
 407   m = gfc_match (" null ( )");
 408   if (m != MATCH_YES)
 409     return m;
 410
 411   /* The NULL symbol now has to be/become an intrinsic function.  */
 412   if (gfc_get_symbol ("null", NULL, &sym))
 413     {
 414       gfc_error ("NULL() initialization at %C is ambiguous");
 415       return MATCH_ERROR;
 416     }
 417
 418   gfc_intrinsic_symbol (sym);
 419
 420   if (sym->attr.proc != PROC_INTRINSIC
 421       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
 422           || gfc_add_function (&sym->attr, NULL) == FAILURE))
 423     return MATCH_ERROR;
 424
 425   e = gfc_get_expr ();
 426   e->where = *gfc_current_locus ();
 427   e->expr_type = EXPR_NULL;
 428   e->ts.type = BT_UNKNOWN;
 429
 430   *result = e;
 431
 432   return MATCH_YES;
 433 }
 434
 435
 436 /* Match a variable name with an optional initializer.  When this
 437    subroutine is called, a variable is expected to be parsed next.
 438    Depending on what is happening at the moment, updates either the
 439    symbol table or the current interface.  */
 440
 441 static match
 442 variable_decl (void)
 443 {
 444   char name[GFC_MAX_SYMBOL_LEN + 1];
 445   gfc_expr *initializer, *char_len;
 446   gfc_array_spec *as;
 447   gfc_charlen *cl;
 448   locus var_locus;
 449   match m;
 450   try t;
 451
 452   initializer = NULL;
 453   as = NULL;
 454
 455   /* When we get here, we've just matched a list of attributes and
 456      maybe a type and a double colon.  The next thing we expect to see
 457      is the name of the symbol.  */
 458   m = gfc_match_name (name);
 459   if (m != MATCH_YES)
 460     goto cleanup;
 461
 462   var_locus = *gfc_current_locus ();
 463
 464   /* Now we could see the optional array spec. or character length.  */
 465   m = gfc_match_array_spec (&as);
 466   if (m == MATCH_ERROR)
 467     goto cleanup;
 468   if (m == MATCH_NO)
 469     as = gfc_copy_array_spec (current_as);
 470
 471   char_len = NULL;
 472   cl = NULL;
 473
 474   if (current_ts.type == BT_CHARACTER)
 475     {
 476       switch (match_char_length (&char_len))
 477         {
 478         case MATCH_YES:
 479           cl = gfc_get_charlen ();
 480           cl->next = gfc_current_ns->cl_list;
 481           gfc_current_ns->cl_list = cl;
 482
 483           cl->length = char_len;
 484           break;
 485
 486         case MATCH_NO:
 487           cl = current_ts.cl;
 488           break;
 489
 490         case MATCH_ERROR:
 491           goto cleanup;
 492         }
 493     }
 494
 495   /* OK, we've successfully matched the declaration.  Now put the
 496      symbol in the current namespace, because it might be used in the
 497      optional intialization expression for this symbol, e.g. this is
 498      perfectly legal:
 499
 500      integer, parameter :: i = huge(i)
 501
 502      This is only true for parameters or variables of a basic type.
 503      For components of derived types, it is not true, so we don't
 504      create a symbol for those yet.  If we fail to create the symbol,
 505      bail out.  */
 506   if (gfc_current_state () != COMP_DERIVED
 507       && build_sym (name, cl, &as, &var_locus) == FAILURE)
 508     {
 509       m = MATCH_ERROR;
 510       goto cleanup;
 511     }
 512
 513   /* In functions that have a RESULT variable defined, the function
 514      name always refers to function calls.  Therefore, the name is
 515      not allowed to appear in specification statements.  */
 516   if (gfc_current_state () == COMP_FUNCTION
 517       && gfc_current_block () != NULL
 518       && gfc_current_block ()->result != NULL
 519       && gfc_current_block ()->result != gfc_current_block ()
 520       && strcmp (gfc_current_block ()->name, name) == 0)
 521     {
 522       gfc_error ("Function name '%s' not allowed at %C", name);
 523       m = MATCH_ERROR;
 524       goto cleanup;
 525     }
 526
 527   /* The double colon must be present in order to have initializers.
 528      Otherwise the statement is ambiguous with an assignment statement.  */
 529   if (colon_seen)
 530     {
 531       if (gfc_match (" =>") == MATCH_YES)
 532         {
 533
 534           if (!current_attr.pointer)
 535             {
 536               gfc_error ("Initialization at %C isn't for a pointer variable");
 537               m = MATCH_ERROR;
 538               goto cleanup;
 539             }
 540
 541           m = gfc_match_null (&initializer);
 542           if (m == MATCH_NO)
 543             {
 544               gfc_error ("Pointer initialization requires a NULL at %C");
 545               m = MATCH_ERROR;
 546             }
 547
 548           if (gfc_pure (NULL))
 549             {
 550               gfc_error
 551                 ("Initialization of pointer at %C is not allowed in a "
 552                  "PURE procedure");
 553               m = MATCH_ERROR;
 554             }
 555
 556           if (m != MATCH_YES)
 557             goto cleanup;
 558
 559           initializer->ts = current_ts;
 560
 561         }
 562       else if (gfc_match_char ('=') == MATCH_YES)
 563         {
 564           if (current_attr.pointer)
 565             {
 566               gfc_error
 567                 ("Pointer initialization at %C requires '=>', not '='");
 568               m = MATCH_ERROR;
 569               goto cleanup;
 570             }
 571
 572           m = gfc_match_init_expr (&initializer);
 573           if (m == MATCH_NO)
 574             {
 575               gfc_error ("Expected an initialization expression at %C");
 576               m = MATCH_ERROR;
 577             }
 578
 579           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
 580             {
 581               gfc_error
 582                 ("Initialization of variable at %C is not allowed in a "
 583                  "PURE procedure");
 584               m = MATCH_ERROR;
 585             }
 586
 587           if (m != MATCH_YES)
 588             goto cleanup;
 589         }
 590     }
 591
 592   /* Add the initializer.  Note that it is fine if initializer is
 593      NULL here, because we sometimes also need to check if a
 594      declaration *must* have an initialization expression.  */
 595   if (gfc_current_state () != COMP_DERIVED)
 596     t = add_init_expr_to_sym (name, &initializer, &var_locus);
 597   else
 598     {
 599       if (current_ts.type == BT_DERIVED && !initializer)
 600         initializer = gfc_default_initializer (&current_ts);
 601       t = build_struct (name, cl, &initializer, &as);
 602     }
 603
 604   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
 605
 606 cleanup:
 607   /* Free stuff up and return.  */
 608   gfc_free_expr (initializer);
 609   gfc_free_array_spec (as);
 610
 611   return m;
 612 }
 613
 614
 615 /* Match an extended-f77 kind specification.  */
 616
 617 match
 618 gfc_match_old_kind_spec (gfc_typespec * ts)
 619 {
 620   match m;
 621
 622   if (gfc_match_char ('*') != MATCH_YES)
 623     return MATCH_NO;
 624
 625   m = gfc_match_small_literal_int (&ts->kind);
 626   if (m != MATCH_YES)
 627     return MATCH_ERROR;
 628
 629   /* Massage the kind numbers for complex types.  */
 630   if (ts->type == BT_COMPLEX && ts->kind == 8)
 631     ts->kind = 4;
 632   if (ts->type == BT_COMPLEX && ts->kind == 16)
 633     ts->kind = 8;
 634
 635   if (gfc_validate_kind (ts->type, ts->kind) == -1)
 636     {
 637       gfc_error ("Old-style kind %d not supported for type %s at %C",
 638                  ts->kind, gfc_basic_typename (ts->type));
 639
 640       return MATCH_ERROR;
 641     }
 642
 643   return MATCH_YES;
 644 }
 645
 646
 647 /* Match a kind specification.  Since kinds are generally optional, we
 648    usually return MATCH_NO if something goes wrong.  If a "kind="
 649    string is found, then we know we have an error.  */
 650
 651 match
 652 gfc_match_kind_spec (gfc_typespec * ts)
 653 {
 654   locus where;
 655   gfc_expr *e;
 656   match m, n;
 657   const char *msg;
 658
 659   m = MATCH_NO;
 660   e = NULL;
 661
 662   where = *gfc_current_locus ();
 663
 664   if (gfc_match_char ('(') == MATCH_NO)
 665     return MATCH_NO;
 666
 667   /* Also gobbles optional text.  */
 668   if (gfc_match (" kind = ") == MATCH_YES)
 669     m = MATCH_ERROR;
 670
 671   n = gfc_match_init_expr (&e);
 672   if (n == MATCH_NO)
 673     gfc_error ("Expected initialization expression at %C");
 674   if (n != MATCH_YES)
 675     return MATCH_ERROR;
 676
 677   if (e->rank != 0)
 678     {
 679       gfc_error ("Expected scalar initialization expression at %C");
 680       m = MATCH_ERROR;
 681       goto no_match;
 682     }
 683
 684   msg = gfc_extract_int (e, &ts->kind);
 685   if (msg != NULL)
 686     {
 687       gfc_error (msg);
 688       m = MATCH_ERROR;
 689       goto no_match;
 690     }
 691
 692   gfc_free_expr (e);
 693   e = NULL;
 694
 695   if (gfc_validate_kind (ts->type, ts->kind) == -1)
 696     {
 697       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
 698                  gfc_basic_typename (ts->type));
 699
 700       m = MATCH_ERROR;
 701       goto no_match;
 702     }
 703
 704   if (gfc_match_char (')') != MATCH_YES)
 705     {
 706       gfc_error ("Missing right paren at %C");
 707       goto no_match;
 708     }
 709
 710   return MATCH_YES;
 711
 712 no_match:
 713   gfc_free_expr (e);
 714   gfc_set_locus (&where);
 715   return m;
 716 }
 717
 718
 719 /* Match the various kind/length specifications in a CHARACTER
 720    declaration.  We don't return MATCH_NO.  */
 721
 722 static match
 723 match_char_spec (gfc_typespec * ts)
 724 {
 725   int i, kind, seen_length;
 726   gfc_charlen *cl;
 727   gfc_expr *len;
 728   match m;
 729
 730   kind = gfc_default_character_kind ();
 731   len = NULL;
 732   seen_length = 0;
 733
 734   /* Try the old-style specification first.  */
 735   old_char_selector = 0;
 736
 737   m = match_char_length (&len);
 738   if (m != MATCH_NO)
 739     {
 740       if (m == MATCH_YES)
 741         old_char_selector = 1;
 742       seen_length = 1;
 743       goto done;
 744     }
 745
 746   m = gfc_match_char ('(');
 747   if (m != MATCH_YES)
 748     {
 749       m = MATCH_YES;    /* character without length is a single char */
 750       goto done;
 751     }
 752
 753   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] )   */
 754   if (gfc_match (" kind =") == MATCH_YES)
 755     {
 756       m = gfc_match_small_int (&kind);
 757       if (m == MATCH_ERROR)
 758         goto done;
 759       if (m == MATCH_NO)
 760         goto syntax;
 761
 762       if (gfc_match (" , len =") == MATCH_NO)
 763         goto rparen;
 764
 765       m = char_len_param_value (&len);
 766       if (m == MATCH_NO)
 767         goto syntax;
 768       if (m == MATCH_ERROR)
 769         goto done;
 770       seen_length = 1;
 771
 772       goto rparen;
 773     }
 774
 775   /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> )  */
 776   if (gfc_match (" len =") == MATCH_YES)
 777     {
 778       m = char_len_param_value (&len);
 779       if (m == MATCH_NO)
 780         goto syntax;
 781       if (m == MATCH_ERROR)
 782         goto done;
 783       seen_length = 1;
 784
 785       if (gfc_match_char (')') == MATCH_YES)
 786         goto done;
 787
 788       if (gfc_match (" , kind =") != MATCH_YES)
 789         goto syntax;
 790
 791       gfc_match_small_int (&kind);
 792
 793       if (gfc_validate_kind (BT_CHARACTER, kind) == -1)
 794         {
 795           gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
 796           return MATCH_YES;
 797         }
 798
 799       goto rparen;
 800     }
 801
 802   /* Try to match   ( <len-param> ) or ( <len-param> , [ KIND = ] <int> )  */
 803   m = char_len_param_value (&len);
 804   if (m == MATCH_NO)
 805     goto syntax;
 806   if (m == MATCH_ERROR)
 807     goto done;
 808   seen_length = 1;
 809
 810   m = gfc_match_char (')');
 811   if (m == MATCH_YES)
 812     goto done;
 813
 814   if (gfc_match_char (',') != MATCH_YES)
 815     goto syntax;
 816
 817   gfc_match (" kind =");        /* Gobble optional text */
 818
 819   m = gfc_match_small_int (&kind);
 820   if (m == MATCH_ERROR)
 821     goto done;
 822   if (m == MATCH_NO)
 823     goto syntax;
 824
 825 rparen:
 826   /* Require a right-paren at this point.  */
 827   m = gfc_match_char (')');
 828   if (m == MATCH_YES)
 829     goto done;
 830
 831 syntax:
 832   gfc_error ("Syntax error in CHARACTER declaration at %C");
 833   m = MATCH_ERROR;
 834
 835 done:
 836   if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind) == -1)
 837     {
 838       gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
 839       m = MATCH_ERROR;
 840     }
 841
 842   if (m != MATCH_YES)
 843     {
 844       gfc_free_expr (len);
 845       return m;
 846     }
 847
 848   /* Do some final massaging of the length values.  */
 849   cl = gfc_get_charlen ();
 850   cl->next = gfc_current_ns->cl_list;
 851   gfc_current_ns->cl_list = cl;
 852
 853   if (seen_length == 0)
 854     cl->length = gfc_int_expr (1);
 855   else
 856     {
 857       if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
 858         cl->length = len;
 859       else
 860         {
 861           gfc_free_expr (len);
 862           cl->length = gfc_int_expr (0);
 863         }
 864     }
 865
 866   ts->cl = cl;
 867   ts->kind = kind;
 868
 869   return MATCH_YES;
 870 }
 871
 872
 873 /* Matches a type specification.  If successful, sets the ts structure
 874    to the matched specification.  This is necessary for FUNCTION and
 875    IMPLICIT statements.
 876
 877    If kind_flag is nonzero, then we check for the optional kind
 878    specification.  Not doing so is needed for matching an IMPLICIT
 879    statement correctly.  */
 880
 881 match
 882 gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
 883 {
 884   char name[GFC_MAX_SYMBOL_LEN + 1];
 885   gfc_symbol *sym;
 886   match m;
 887
 888   gfc_clear_ts (ts);
 889
 890   if (gfc_match (" integer") == MATCH_YES)
 891     {
 892       ts->type = BT_INTEGER;
 893       ts->kind = gfc_default_integer_kind ();
 894       goto get_kind;
 895     }
 896
 897   if (gfc_match (" character") == MATCH_YES)
 898     {
 899       ts->type = BT_CHARACTER;
 900       return match_char_spec (ts);
 901     }
 902
 903   if (gfc_match (" real") == MATCH_YES)
 904     {
 905       ts->type = BT_REAL;
 906       ts->kind = gfc_default_real_kind ();
 907       goto get_kind;
 908     }
 909
 910   if (gfc_match (" double precision") == MATCH_YES)
 911     {
 912       ts->type = BT_REAL;
 913       ts->kind = gfc_default_double_kind ();
 914       return MATCH_YES;
 915     }
 916
 917   if (gfc_match (" complex") == MATCH_YES)
 918     {
 919       ts->type = BT_COMPLEX;
 920       ts->kind = gfc_default_complex_kind ();
 921       goto get_kind;
 922     }
 923
 924   if (gfc_match (" double complex") == MATCH_YES)
 925     {
 926       ts->type = BT_COMPLEX;
 927       ts->kind = gfc_default_double_kind ();
 928       return MATCH_YES;
 929     }
 930
 931   if (gfc_match (" logical") == MATCH_YES)
 932     {
 933       ts->type = BT_LOGICAL;
 934       ts->kind = gfc_default_logical_kind ();
 935       goto get_kind;
 936     }
 937
 938   m = gfc_match (" type ( %n )", name);
 939   if (m != MATCH_YES)
 940     return m;
 941
 942   /* Search for the name but allow the components to be defined later.  */
 943   if (gfc_get_ha_symbol (name, &sym))
 944     {
 945       gfc_error ("Type name '%s' at %C is ambiguous", name);
 946       return MATCH_ERROR;
 947     }
 948
 949   if (sym->attr.flavor != FL_DERIVED
 950       && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
 951     return MATCH_ERROR;
 952
 953   ts->type = BT_DERIVED;
 954   ts->kind = 0;
 955   ts->derived = sym;
 956
 957   return MATCH_YES;
 958
 959 get_kind:
 960   /* For all types except double, derived and character, look for an
 961      optional kind specifier.  MATCH_NO is actually OK at this point.  */
 962   if (kind_flag == 0)
 963     return MATCH_YES;
 964
 965   m = gfc_match_kind_spec (ts);
 966   if (m == MATCH_NO && ts->type != BT_CHARACTER)
 967     m = gfc_match_old_kind_spec (ts);
 968
 969   if (m == MATCH_NO)
 970     m = MATCH_YES;              /* No kind specifier found.  */
 971
 972   return m;
 973 }
 974
 975
 976 /* Matches an attribute specification including array specs.  If
 977    successful, leaves the variables current_attr and current_as
 978    holding the specification.  Also sets the colon_seen variable for
 979    later use by matchers associated with initializations.
 980
 981    This subroutine is a little tricky in the sense that we don't know
 982    if we really have an attr-spec until we hit the double colon.
 983    Until that time, we can only return MATCH_NO.  This forces us to
 984    check for duplicate specification at this level.  */
 985
 986 static match
 987 match_attr_spec (void)
 988 {
 989
 990   /* Modifiers that can exist in a type statement.  */
 991   typedef enum
 992   { GFC_DECL_BEGIN = 0,
 993     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
 994     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
 995     DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
 996     DECL_TARGET, DECL_COLON, DECL_NONE,
 997     GFC_DECL_END /* Sentinel */
 998   }
 999   decl_types;
1000
1001 /* GFC_DECL_END is the sentinel, index starts at 0.  */
1002 #define NUM_DECL GFC_DECL_END
1003
1004   static mstring decls[] = {
1005     minit (", allocatable", DECL_ALLOCATABLE),
1006     minit (", dimension", DECL_DIMENSION),
1007     minit (", external", DECL_EXTERNAL),
1008     minit (", intent ( in )", DECL_IN),
1009     minit (", intent ( out )", DECL_OUT),
1010     minit (", intent ( in out )", DECL_INOUT),
1011     minit (", intrinsic", DECL_INTRINSIC),
1012     minit (", optional", DECL_OPTIONAL),
1013     minit (", parameter", DECL_PARAMETER),
1014     minit (", pointer", DECL_POINTER),
1015     minit (", private", DECL_PRIVATE),
1016     minit (", public", DECL_PUBLIC),
1017     minit (", save", DECL_SAVE),
1018     minit (", target", DECL_TARGET),
1019     minit ("::", DECL_COLON),
1020     minit (NULL, DECL_NONE)
1021   };
1022
1023   locus start, seen_at[NUM_DECL];
1024   int seen[NUM_DECL];
1025   decl_types d;
1026   const char *attr;
1027   match m;
1028   try t;
1029
1030   gfc_clear_attr (&current_attr);
1031   start = *gfc_current_locus ();
1032
1033   current_as = NULL;
1034   colon_seen = 0;
1035
1036   /* See if we get all of the keywords up to the final double colon.  */
1037   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1038     seen[d] = 0;
1039
1040   for (;;)
1041     {
1042       d = (decl_types) gfc_match_strings (decls);
1043       if (d == DECL_NONE || d == DECL_COLON)
1044         break;
1045
1046       seen[d]++;
1047       seen_at[d] = *gfc_current_locus ();
1048
1049       if (d == DECL_DIMENSION)
1050         {
1051           m = gfc_match_array_spec (&current_as);
1052
1053           if (m == MATCH_NO)
1054             {
1055               gfc_error ("Missing dimension specification at %C");
1056               m = MATCH_ERROR;
1057             }
1058
1059           if (m == MATCH_ERROR)
1060             goto cleanup;
1061         }
1062     }
1063
1064   /* No double colon, so assume that we've been looking at something
1065      else the whole time.  */
1066   if (d == DECL_NONE)
1067     {
1068       m = MATCH_NO;
1069       goto cleanup;
1070     }
1071
1072   /* Since we've seen a double colon, we have to be looking at an
1073      attr-spec.  This means that we can now issue errors.  */
1074   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1075     if (seen[d] > 1)
1076       {
1077         switch (d)
1078           {
1079           case DECL_ALLOCATABLE:
1080             attr = "ALLOCATABLE";
1081             break;
1082           case DECL_DIMENSION:
1083             attr = "DIMENSION";
1084             break;
1085           case DECL_EXTERNAL:
1086             attr = "EXTERNAL";
1087             break;
1088           case DECL_IN:
1089             attr = "INTENT (IN)";
1090             break;
1091           case DECL_OUT:
1092             attr = "INTENT (OUT)";
1093             break;
1094           case DECL_INOUT:
1095             attr = "INTENT (IN OUT)";
1096             break;
1097           case DECL_INTRINSIC:
1098             attr = "INTRINSIC";
1099             break;
1100           case DECL_OPTIONAL:
1101             attr = "OPTIONAL";
1102             break;
1103           case DECL_PARAMETER:
1104             attr = "PARAMETER";
1105             break;
1106           case DECL_POINTER:
1107             attr = "POINTER";
1108             break;
1109           case DECL_PRIVATE:
1110             attr = "PRIVATE";
1111             break;
1112           case DECL_PUBLIC:
1113             attr = "PUBLIC";
1114             break;
1115           case DECL_SAVE:
1116             attr = "SAVE";
1117             break;
1118           case DECL_TARGET:
1119             attr = "TARGET";
1120             break;
1121           default:
1122             attr = NULL;        /* This shouldn't happen */
1123           }
1124
1125         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1126         m = MATCH_ERROR;
1127         goto cleanup;
1128       }
1129
1130   /* Now that we've dealt with duplicate attributes, add the attributes
1131      to the current attribute.  */
1132   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1133     {
1134       if (seen[d] == 0)
1135         continue;
1136
1137       if (gfc_current_state () == COMP_DERIVED
1138           && d != DECL_DIMENSION && d != DECL_POINTER
1139           && d != DECL_COLON && d != DECL_NONE)
1140         {
1141
1142           gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1143                      &seen_at[d]);
1144           m = MATCH_ERROR;
1145           goto cleanup;
1146         }
1147
1148       switch (d)
1149         {
1150         case DECL_ALLOCATABLE:
1151           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
1152           break;
1153
1154         case DECL_DIMENSION:
1155           t = gfc_add_dimension (&current_attr, &seen_at[d]);
1156           break;
1157
1158         case DECL_EXTERNAL:
1159           t = gfc_add_external (&current_attr, &seen_at[d]);
1160           break;
1161
1162         case DECL_IN:
1163           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
1164           break;
1165
1166         case DECL_OUT:
1167           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
1168           break;
1169
1170         case DECL_INOUT:
1171           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
1172           break;
1173
1174         case DECL_INTRINSIC:
1175           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
1176           break;
1177
1178         case DECL_OPTIONAL:
1179           t = gfc_add_optional (&current_attr, &seen_at[d]);
1180           break;
1181
1182         case DECL_PARAMETER:
1183           t = gfc_add_flavor (&current_attr, FL_PARAMETER, &seen_at[d]);
1184           break;
1185
1186         case DECL_POINTER:
1187           t = gfc_add_pointer (&current_attr, &seen_at[d]);
1188           break;
1189
1190         case DECL_PRIVATE:
1191           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, &seen_at[d]);
1192           break;
1193
1194         case DECL_PUBLIC:
1195           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, &seen_at[d]);
1196           break;
1197
1198         case DECL_SAVE:
1199           t = gfc_add_save (&current_attr, &seen_at[d]);
1200           break;
1201
1202         case DECL_TARGET:
1203           t = gfc_add_target (&current_attr, &seen_at[d]);
1204           break;
1205
1206         default:
1207           gfc_internal_error ("match_attr_spec(): Bad attribute");
1208         }
1209
1210       if (t == FAILURE)
1211         {
1212           m = MATCH_ERROR;
1213           goto cleanup;
1214         }
1215     }
1216
1217   colon_seen = 1;
1218   return MATCH_YES;
1219
1220 cleanup:
1221   gfc_set_locus (&start);
1222   gfc_free_array_spec (current_as);
1223   current_as = NULL;
1224   return m;
1225 }
1226
1227
1228 /* Match a data declaration statement.  */
1229
1230 match
1231 gfc_match_data_decl (void)
1232 {
1233   gfc_symbol *sym;
1234   match m;
1235
1236   m = gfc_match_type_spec (&current_ts, 1);
1237   if (m != MATCH_YES)
1238     return m;
1239
1240   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
1241     {
1242       sym = gfc_use_derived (current_ts.derived);
1243
1244       if (sym == NULL)
1245         {
1246           m = MATCH_ERROR;
1247           goto cleanup;
1248         }
1249
1250       current_ts.derived = sym;
1251     }
1252
1253   m = match_attr_spec ();
1254   if (m == MATCH_ERROR)
1255     {
1256       m = MATCH_NO;
1257       goto cleanup;
1258     }
1259
1260   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
1261     {
1262
1263       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
1264         goto ok;
1265
1266       if (gfc_find_symbol (current_ts.derived->name,
1267                            current_ts.derived->ns->parent, 1, &sym) == 0)
1268         goto ok;
1269
1270       /* Hope that an ambiguous symbol is itself masked by a type definition.  */
1271       if (sym != NULL && sym->attr.flavor == FL_DERIVED)
1272         goto ok;
1273
1274       gfc_error ("Derived type at %C has not been previously defined");
1275       m = MATCH_ERROR;
1276       goto cleanup;
1277     }
1278
1279 ok:
1280   /* If we have an old-style character declaration, and no new-style
1281      attribute specifications, then there a comma is optional between
1282      the type specification and the variable list.  */
1283   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
1284     gfc_match_char (',');
1285
1286   /* Give the types/attributes to symbols that follow.  */
1287   for (;;)
1288     {
1289       m = variable_decl ();
1290       if (m == MATCH_ERROR)
1291         goto cleanup;
1292       if (m == MATCH_NO)
1293         break;
1294
1295       if (gfc_match_eos () == MATCH_YES)
1296         goto cleanup;
1297       if (gfc_match_char (',') != MATCH_YES)
1298         break;
1299     }
1300
1301   gfc_error ("Syntax error in data declaration at %C");
1302   m = MATCH_ERROR;
1303
1304 cleanup:
1305   gfc_free_array_spec (current_as);
1306   current_as = NULL;
1307   return m;
1308 }
1309
1310
1311 /* Match a prefix associated with a function or subroutine
1312    declaration.  If the typespec pointer is nonnull, then a typespec
1313    can be matched.  Note that if nothing matches, MATCH_YES is
1314    returned (the null string was matched).  */
1315
1316 static match
1317 match_prefix (gfc_typespec * ts)
1318 {
1319   int seen_type;
1320
1321   gfc_clear_attr (&current_attr);
1322   seen_type = 0;
1323
1324 loop:
1325   if (!seen_type && ts != NULL
1326       && gfc_match_type_spec (ts, 1) == MATCH_YES
1327       && gfc_match_space () == MATCH_YES)
1328     {
1329
1330       seen_type = 1;
1331       goto loop;
1332     }
1333
1334   if (gfc_match ("elemental% ") == MATCH_YES)
1335     {
1336       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
1337         return MATCH_ERROR;
1338
1339       goto loop;
1340     }
1341
1342   if (gfc_match ("pure% ") == MATCH_YES)
1343     {
1344       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
1345         return MATCH_ERROR;
1346
1347       goto loop;
1348     }
1349
1350   if (gfc_match ("recursive% ") == MATCH_YES)
1351     {
1352       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
1353         return MATCH_ERROR;
1354
1355       goto loop;
1356     }
1357
1358   /* At this point, the next item is not a prefix.  */
1359   return MATCH_YES;
1360 }
1361
1362
1363 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
1364
1365 static try
1366 copy_prefix (symbol_attribute * dest, locus * where)
1367 {
1368
1369   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
1370     return FAILURE;
1371
1372   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
1373     return FAILURE;
1374
1375   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
1376     return FAILURE;
1377
1378   return SUCCESS;
1379 }
1380
1381
1382 /* Match a formal argument list.  */
1383
1384 match
1385 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
1386 {
1387   gfc_formal_arglist *head, *tail, *p, *q;
1388   char name[GFC_MAX_SYMBOL_LEN + 1];
1389   gfc_symbol *sym;
1390   match m;
1391
1392   head = tail = NULL;
1393
1394   if (gfc_match_char ('(') != MATCH_YES)
1395     {
1396       if (null_flag)
1397         goto ok;
1398       return MATCH_NO;
1399     }
1400
1401   if (gfc_match_char (')') == MATCH_YES)
1402     goto ok;
1403
1404   for (;;)
1405     {
1406       if (gfc_match_char ('*') == MATCH_YES)
1407         sym = NULL;
1408       else
1409         {
1410           m = gfc_match_name (name);
1411           if (m != MATCH_YES)
1412             goto cleanup;
1413
1414           if (gfc_get_symbol (name, NULL, &sym))
1415             goto cleanup;
1416         }
1417
1418       p = gfc_get_formal_arglist ();
1419
1420       if (head == NULL)
1421         head = tail = p;
1422       else
1423         {
1424           tail->next = p;
1425           tail = p;
1426         }
1427
1428       tail->sym = sym;
1429
1430       /* We don't add the VARIABLE flavor because the name could be a
1431          dummy procedure.  We don't apply these attributes to formal
1432          arguments of statement functions.  */
1433       if (sym != NULL && !st_flag
1434           && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
1435               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
1436         {
1437           m = MATCH_ERROR;
1438           goto cleanup;
1439         }
1440
1441       /* The name of a program unit can be in a different namespace,
1442          so check for it explicitly.  After the statement is accepted,
1443          the name is checked for especially in gfc_get_symbol().  */
1444       if (gfc_new_block != NULL && sym != NULL
1445           && strcmp (sym->name, gfc_new_block->name) == 0)
1446         {
1447           gfc_error ("Name '%s' at %C is the name of the procedure",
1448                      sym->name);
1449           m = MATCH_ERROR;
1450           goto cleanup;
1451         }
1452
1453       if (gfc_match_char (')') == MATCH_YES)
1454         goto ok;
1455
1456       m = gfc_match_char (',');
1457       if (m != MATCH_YES)
1458         {
1459           gfc_error ("Unexpected junk in formal argument list at %C");
1460           goto cleanup;
1461         }
1462     }
1463
1464 ok:
1465   /* Check for duplicate symbols in the formal argument list.  */
1466   if (head != NULL)
1467     {
1468       for (p = head; p->next; p = p->next)
1469         {
1470           if (p->sym == NULL)
1471             continue;
1472
1473           for (q = p->next; q; q = q->next)
1474             if (p->sym == q->sym)
1475               {
1476                 gfc_error
1477                   ("Duplicate symbol '%s' in formal argument list at %C",
1478                    p->sym->name);
1479
1480                 m = MATCH_ERROR;
1481                 goto cleanup;
1482               }
1483         }
1484     }
1485
1486   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
1487       FAILURE)
1488     {
1489       m = MATCH_ERROR;
1490       goto cleanup;
1491     }
1492
1493   return MATCH_YES;
1494
1495 cleanup:
1496   gfc_free_formal_arglist (head);
1497   return m;
1498 }
1499
1500
1501 /* Match a RESULT specification following a function declaration or
1502    ENTRY statement.  Also matches the end-of-statement.  */
1503
1504 static match
1505 match_result (gfc_symbol * function, gfc_symbol ** result)
1506 {
1507   char name[GFC_MAX_SYMBOL_LEN + 1];
1508   gfc_symbol *r;
1509   match m;
1510
1511   if (gfc_match (" result (") != MATCH_YES)
1512     return MATCH_NO;
1513
1514   m = gfc_match_name (name);
1515   if (m != MATCH_YES)
1516     return m;
1517
1518   if (gfc_match (" )%t") != MATCH_YES)
1519     {
1520       gfc_error ("Unexpected junk following RESULT variable at %C");
1521       return MATCH_ERROR;
1522     }
1523
1524   if (strcmp (function->name, name) == 0)
1525     {
1526       gfc_error
1527         ("RESULT variable at %C must be different than function name");
1528       return MATCH_ERROR;
1529     }
1530
1531   if (gfc_get_symbol (name, NULL, &r))
1532     return MATCH_ERROR;
1533
1534   if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
1535       || gfc_add_result (&r->attr, NULL) == FAILURE)
1536     return MATCH_ERROR;
1537
1538   *result = r;
1539
1540   return MATCH_YES;
1541 }
1542
1543
1544 /* Match a function declaration.  */
1545
1546 match
1547 gfc_match_function_decl (void)
1548 {
1549   char name[GFC_MAX_SYMBOL_LEN + 1];
1550   gfc_symbol *sym, *result;
1551   locus old_loc;
1552   match m;
1553
1554   if (gfc_current_state () != COMP_NONE
1555       && gfc_current_state () != COMP_INTERFACE
1556       && gfc_current_state () != COMP_CONTAINS)
1557     return MATCH_NO;
1558
1559   gfc_clear_ts (&current_ts);
1560
1561   old_loc = *gfc_current_locus ();
1562
1563   m = match_prefix (&current_ts);
1564   if (m != MATCH_YES)
1565     {
1566       gfc_set_locus (&old_loc);
1567       return m;
1568     }
1569
1570   if (gfc_match ("function% %n", name) != MATCH_YES)
1571     {
1572       gfc_set_locus (&old_loc);
1573       return MATCH_NO;
1574     }
1575
1576   if (get_proc_name (name, &sym))
1577     return MATCH_ERROR;
1578   gfc_new_block = sym;
1579
1580   m = gfc_match_formal_arglist (sym, 0, 0);
1581   if (m == MATCH_NO)
1582     gfc_error ("Expected formal argument list in function definition at %C");
1583   else if (m == MATCH_ERROR)
1584     goto cleanup;
1585
1586   result = NULL;
1587
1588   if (gfc_match_eos () != MATCH_YES)
1589     {
1590       /* See if a result variable is present.  */
1591       m = match_result (sym, &result);
1592       if (m == MATCH_NO)
1593         gfc_error ("Unexpected junk after function declaration at %C");
1594
1595       if (m != MATCH_YES)
1596         {
1597           m = MATCH_ERROR;
1598           goto cleanup;
1599         }
1600     }
1601
1602   /* Make changes to the symbol.  */
1603   m = MATCH_ERROR;
1604
1605   if (gfc_add_function (&sym->attr, NULL) == FAILURE)
1606     goto cleanup;
1607
1608   if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
1609       || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1610     goto cleanup;
1611
1612   if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
1613     {
1614       gfc_error ("Function '%s' at %C already has a type of %s", name,
1615                  gfc_basic_typename (sym->ts.type));
1616       goto cleanup;
1617     }
1618
1619   if (result == NULL)
1620     {
1621       sym->ts = current_ts;
1622       sym->result = sym;
1623     }
1624   else
1625     {
1626       result->ts = current_ts;
1627       sym->result = result;
1628     }
1629
1630   return MATCH_YES;
1631
1632 cleanup:
1633   gfc_set_locus (&old_loc);
1634   return m;
1635 }
1636
1637
1638 /* Match an ENTRY statement.  */
1639
1640 match
1641 gfc_match_entry (void)
1642 {
1643   gfc_symbol *function, *result, *entry;
1644   char name[GFC_MAX_SYMBOL_LEN + 1];
1645   gfc_compile_state state;
1646   match m;
1647
1648   m = gfc_match_name (name);
1649   if (m != MATCH_YES)
1650     return m;
1651
1652   if (get_proc_name (name, &entry))
1653     return MATCH_ERROR;
1654
1655   gfc_enclosing_unit (&state);
1656   switch (state)
1657     {
1658     case COMP_SUBROUTINE:
1659       m = gfc_match_formal_arglist (entry, 0, 1);
1660       if (m != MATCH_YES)
1661         return MATCH_ERROR;
1662
1663       if (gfc_current_state () != COMP_SUBROUTINE)
1664         goto exec_construct;
1665
1666       if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1667           || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
1668         return MATCH_ERROR;
1669
1670       break;
1671
1672     case COMP_FUNCTION:
1673       m = gfc_match_formal_arglist (entry, 0, 0);
1674       if (m != MATCH_YES)
1675         return MATCH_ERROR;
1676
1677       if (gfc_current_state () != COMP_FUNCTION)
1678         goto exec_construct;
1679       function = gfc_state_stack->sym;
1680
1681       result = NULL;
1682
1683       if (gfc_match_eos () == MATCH_YES)
1684         {
1685           if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1686               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1687             return MATCH_ERROR;
1688
1689           entry->result = function->result;
1690
1691         }
1692       else
1693         {
1694           m = match_result (function, &result);
1695           if (m == MATCH_NO)
1696             gfc_syntax_error (ST_ENTRY);
1697           if (m != MATCH_YES)
1698             return MATCH_ERROR;
1699
1700           if (gfc_add_result (&result->attr, NULL) == FAILURE
1701               || gfc_add_entry (&entry->attr, NULL) == FAILURE
1702               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1703             return MATCH_ERROR;
1704         }
1705
1706       if (function->attr.recursive && result == NULL)
1707         {
1708           gfc_error ("RESULT attribute required in ENTRY statement at %C");
1709           return MATCH_ERROR;
1710         }
1711
1712       break;
1713
1714     default:
1715       goto exec_construct;
1716     }
1717
1718   if (gfc_match_eos () != MATCH_YES)
1719     {
1720       gfc_syntax_error (ST_ENTRY);
1721       return MATCH_ERROR;
1722     }
1723
1724   return MATCH_YES;
1725
1726 exec_construct:
1727   gfc_error ("ENTRY statement at %C cannot appear within %s",
1728              gfc_state_name (gfc_current_state ()));
1729
1730   return MATCH_ERROR;
1731 }
1732
1733
1734 /* Match a subroutine statement, including optional prefixes.  */
1735
1736 match
1737 gfc_match_subroutine (void)
1738 {
1739   char name[GFC_MAX_SYMBOL_LEN + 1];
1740   gfc_symbol *sym;
1741   match m;
1742
1743   if (gfc_current_state () != COMP_NONE
1744       && gfc_current_state () != COMP_INTERFACE
1745       && gfc_current_state () != COMP_CONTAINS)
1746     return MATCH_NO;
1747
1748   m = match_prefix (NULL);
1749   if (m != MATCH_YES)
1750     return m;
1751
1752   m = gfc_match ("subroutine% %n", name);
1753   if (m != MATCH_YES)
1754     return m;
1755
1756   if (get_proc_name (name, &sym))
1757     return MATCH_ERROR;
1758   gfc_new_block = sym;
1759
1760   if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1761     return MATCH_ERROR;
1762
1763   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
1764     return MATCH_ERROR;
1765
1766   if (gfc_match_eos () != MATCH_YES)
1767     {
1768       gfc_syntax_error (ST_SUBROUTINE);
1769       return MATCH_ERROR;
1770     }
1771
1772   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1773     return MATCH_ERROR;
1774
1775   return MATCH_YES;
1776 }
1777
1778
1779 /* Match any of the various end-block statements.  Returns the type of
1780    END to the caller.  The END INTERFACE, END IF, END DO and END
1781    SELECT statements cannot be replaced by a single END statement.  */
1782
1783 match
1784 gfc_match_end (gfc_statement * st)
1785 {
1786   char name[GFC_MAX_SYMBOL_LEN + 1];
1787   gfc_compile_state state;
1788   locus old_loc;
1789   const char *block_name;
1790   const char *target;
1791   match m;
1792
1793   old_loc = *gfc_current_locus ();
1794   if (gfc_match ("end") != MATCH_YES)
1795     return MATCH_NO;
1796
1797   state = gfc_current_state ();
1798   block_name =
1799     gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
1800
1801   if (state == COMP_CONTAINS)
1802     {
1803       state = gfc_state_stack->previous->state;
1804       block_name = gfc_state_stack->previous->sym == NULL ? NULL
1805         : gfc_state_stack->previous->sym->name;
1806     }
1807
1808   switch (state)
1809     {
1810     case COMP_NONE:
1811     case COMP_PROGRAM:
1812       *st = ST_END_PROGRAM;
1813       target = " program";
1814       break;
1815
1816     case COMP_SUBROUTINE:
1817       *st = ST_END_SUBROUTINE;
1818       target = " subroutine";
1819       break;
1820
1821     case COMP_FUNCTION:
1822       *st = ST_END_FUNCTION;
1823       target = " function";
1824       break;
1825
1826     case COMP_BLOCK_DATA:
1827       *st = ST_END_BLOCK_DATA;
1828       target = " block data";
1829       break;
1830
1831     case COMP_MODULE:
1832       *st = ST_END_MODULE;
1833       target = " module";
1834       break;
1835
1836     case COMP_INTERFACE:
1837       *st = ST_END_INTERFACE;
1838       target = " interface";
1839       break;
1840
1841     case COMP_DERIVED:
1842       *st = ST_END_TYPE;
1843       target = " type";
1844       break;
1845
1846     case COMP_IF:
1847       *st = ST_ENDIF;
1848       target = " if";
1849       break;
1850
1851     case COMP_DO:
1852       *st = ST_ENDDO;
1853       target = " do";
1854       break;
1855
1856     case COMP_SELECT:
1857       *st = ST_END_SELECT;
1858       target = " select";
1859       break;
1860
1861     case COMP_FORALL:
1862       *st = ST_END_FORALL;
1863       target = " forall";
1864       break;
1865
1866     case COMP_WHERE:
1867       *st = ST_END_WHERE;
1868       target = " where";
1869       break;
1870
1871     default:
1872       gfc_error ("Unexpected END statement at %C");
1873       goto cleanup;
1874     }
1875
1876   if (gfc_match_eos () == MATCH_YES)
1877     {
1878
1879       if (*st == ST_ENDIF || *st == ST_ENDDO || *st == ST_END_SELECT
1880           || *st == ST_END_INTERFACE || *st == ST_END_FORALL
1881           || *st == ST_END_WHERE)
1882         {
1883
1884           gfc_error ("%s statement expected at %C",
1885                      gfc_ascii_statement (*st));
1886           goto cleanup;
1887         }
1888
1889       return MATCH_YES;
1890     }
1891
1892   /* Verify that we've got the sort of end-block that we're expecting.  */
1893   if (gfc_match (target) != MATCH_YES)
1894     {
1895       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
1896       goto cleanup;
1897     }
1898
1899   /* If we're at the end, make sure a block name wasn't required.  */
1900   if (gfc_match_eos () == MATCH_YES)
1901     {
1902
1903       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
1904         return MATCH_YES;
1905
1906       if (gfc_current_block () == NULL)
1907         return MATCH_YES;
1908
1909       gfc_error ("Expected block name of '%s' in %s statement at %C",
1910                  block_name, gfc_ascii_statement (*st));
1911
1912       return MATCH_ERROR;
1913     }
1914
1915   /* END INTERFACE has a special handler for its several possible endings.  */
1916   if (*st == ST_END_INTERFACE)
1917     return gfc_match_end_interface ();
1918
1919   /* We haven't hit the end of statement, so what is left must be an end-name.  */
1920   m = gfc_match_space ();
1921   if (m == MATCH_YES)
1922     m = gfc_match_name (name);
1923
1924   if (m == MATCH_NO)
1925     gfc_error ("Expected terminating name at %C");
1926   if (m != MATCH_YES)
1927     goto cleanup;
1928
1929   if (block_name == NULL)
1930     goto syntax;
1931
1932   if (strcmp (name, block_name) != 0)
1933     {
1934       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
1935                  gfc_ascii_statement (*st));
1936       goto cleanup;
1937     }
1938
1939   if (gfc_match_eos () == MATCH_YES)
1940     return MATCH_YES;
1941
1942 syntax:
1943   gfc_syntax_error (*st);
1944
1945 cleanup:
1946   gfc_set_locus (&old_loc);
1947   return MATCH_ERROR;
1948 }
1949
1950
1951
1952 /***************** Attribute declaration statements ****************/
1953
1954 /* Set the attribute of a single variable.  */
1955
1956 static match
1957 attr_decl1 (void)
1958 {
1959   char name[GFC_MAX_SYMBOL_LEN + 1];
1960   gfc_array_spec *as;
1961   gfc_symbol *sym;
1962   locus var_locus;
1963   match m;
1964
1965   as = NULL;
1966
1967   m = gfc_match_name (name);
1968   if (m != MATCH_YES)
1969     goto cleanup;
1970
1971   if (find_special (name, &sym))
1972     return MATCH_ERROR;
1973
1974   var_locus = *gfc_current_locus ();
1975
1976   /* Deal with possible array specification for certain attributes.  */
1977   if (current_attr.dimension
1978       || current_attr.allocatable
1979       || current_attr.pointer
1980       || current_attr.target)
1981     {
1982       m = gfc_match_array_spec (&as);
1983       if (m == MATCH_ERROR)
1984         goto cleanup;
1985
1986       if (current_attr.dimension && m == MATCH_NO)
1987         {
1988           gfc_error
1989             ("Missing array specification at %L in DIMENSION statement",
1990              &var_locus);
1991           m = MATCH_ERROR;
1992           goto cleanup;
1993         }
1994
1995       if ((current_attr.allocatable || current_attr.pointer)
1996           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
1997         {
1998           gfc_error ("Array specification must be deferred at %L",
1999                      &var_locus);
2000           m = MATCH_ERROR;
2001           goto cleanup;
2002         }
2003     }
2004
2005   /* Update symbol table.  DIMENSION attribute is set in gfc_set_array_spec().  */
2006   if (current_attr.dimension == 0
2007       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2008     {
2009       m = MATCH_ERROR;
2010       goto cleanup;
2011     }
2012
2013   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2014     {
2015       m = MATCH_ERROR;
2016       goto cleanup;
2017     }
2018
2019   if ((current_attr.external || current_attr.intrinsic)
2020       && sym->attr.flavor != FL_PROCEDURE
2021       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
2022     {
2023       m = MATCH_ERROR;
2024       goto cleanup;
2025     }
2026
2027   return MATCH_YES;
2028
2029 cleanup:
2030   gfc_free_array_spec (as);
2031   return m;
2032 }
2033
2034
2035 /* Generic attribute declaration subroutine.  Used for attributes that
2036    just have a list of names.  */
2037
2038 static match
2039 attr_decl (void)
2040 {
2041   match m;
2042
2043   /* Gobble the optional double colon, by simply ignoring the result
2044      of gfc_match().  */
2045   gfc_match (" ::");
2046
2047   for (;;)
2048     {
2049       m = attr_decl1 ();
2050       if (m != MATCH_YES)
2051         break;
2052
2053       if (gfc_match_eos () == MATCH_YES)
2054         {
2055           m = MATCH_YES;
2056           break;
2057         }
2058
2059       if (gfc_match_char (',') != MATCH_YES)
2060         {
2061           gfc_error ("Unexpected character in variable list at %C");
2062           m = MATCH_ERROR;
2063           break;
2064         }
2065     }
2066
2067   return m;
2068 }
2069
2070
2071 match
2072 gfc_match_external (void)
2073 {
2074
2075   gfc_clear_attr (&current_attr);
2076   gfc_add_external (&current_attr, NULL);
2077
2078   return attr_decl ();
2079 }
2080
2081
2082
2083 match
2084 gfc_match_intent (void)
2085 {
2086   sym_intent intent;
2087
2088   intent = match_intent_spec ();
2089   if (intent == INTENT_UNKNOWN)
2090     return MATCH_ERROR;
2091
2092   gfc_clear_attr (&current_attr);
2093   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2094
2095   return attr_decl ();
2096 }
2097
2098
2099 match
2100 gfc_match_intrinsic (void)
2101 {
2102
2103   gfc_clear_attr (&current_attr);
2104   gfc_add_intrinsic (&current_attr, NULL);
2105
2106   return attr_decl ();
2107 }
2108
2109
2110 match
2111 gfc_match_optional (void)
2112 {
2113
2114   gfc_clear_attr (&current_attr);
2115   gfc_add_optional (&current_attr, NULL);
2116
2117   return attr_decl ();
2118 }
2119
2120
2121 match
2122 gfc_match_pointer (void)
2123 {
2124
2125   gfc_clear_attr (&current_attr);
2126   gfc_add_pointer (&current_attr, NULL);
2127
2128   return attr_decl ();
2129 }
2130
2131
2132 match
2133 gfc_match_allocatable (void)
2134 {
2135
2136   gfc_clear_attr (&current_attr);
2137   gfc_add_allocatable (&current_attr, NULL);
2138
2139   return attr_decl ();
2140 }
2141
2142
2143 match
2144 gfc_match_dimension (void)
2145 {
2146
2147   gfc_clear_attr (&current_attr);
2148   gfc_add_dimension (&current_attr, NULL);
2149
2150   return attr_decl ();
2151 }
2152
2153
2154 match
2155 gfc_match_target (void)
2156 {
2157
2158   gfc_clear_attr (&current_attr);
2159   gfc_add_target (&current_attr, NULL);
2160
2161   return attr_decl ();
2162 }
2163
2164
2165 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2166    statement.  */
2167
2168 static match
2169 access_attr_decl (gfc_statement st)
2170 {
2171   char name[GFC_MAX_SYMBOL_LEN + 1];
2172   interface_type type;
2173   gfc_user_op *uop;
2174   gfc_symbol *sym;
2175   gfc_intrinsic_op operator;
2176   match m;
2177
2178   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2179     goto done;
2180
2181   for (;;)
2182     {
2183       m = gfc_match_generic_spec (&type, name, &operator);
2184       if (m == MATCH_NO)
2185         goto syntax;
2186       if (m == MATCH_ERROR)
2187         return MATCH_ERROR;
2188
2189       switch (type)
2190         {
2191         case INTERFACE_NAMELESS:
2192           goto syntax;
2193
2194         case INTERFACE_GENERIC:
2195           if (gfc_get_symbol (name, NULL, &sym))
2196             goto done;
2197
2198           if (gfc_add_access (&sym->attr,
2199                               (st ==
2200                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2201                               NULL) == FAILURE)
2202             return MATCH_ERROR;
2203
2204           break;
2205
2206         case INTERFACE_INTRINSIC_OP:
2207           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2208             {
2209               gfc_current_ns->operator_access[operator] =
2210                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2211             }
2212           else
2213             {
2214               gfc_error ("Access specification of the %s operator at %C has "
2215                          "already been specified", gfc_op2string (operator));
2216               goto done;
2217             }
2218
2219           break;
2220
2221         case INTERFACE_USER_OP:
2222           uop = gfc_get_uop (name);
2223
2224           if (uop->access == ACCESS_UNKNOWN)
2225             {
2226               uop->access =
2227                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2228             }
2229           else
2230             {
2231               gfc_error
2232                 ("Access specification of the .%s. operator at %C has "
2233                  "already been specified", sym->name);
2234               goto done;
2235             }
2236
2237           break;
2238         }
2239
2240       if (gfc_match_char (',') == MATCH_NO)
2241         break;
2242     }
2243
2244   if (gfc_match_eos () != MATCH_YES)
2245     goto syntax;
2246   return MATCH_YES;
2247
2248 syntax:
2249   gfc_syntax_error (st);
2250
2251 done:
2252   return MATCH_ERROR;
2253 }
2254
2255
2256 /* The PRIVATE statement is a bit weird in that it can be a attribute
2257    declaration, but also works as a standlone statement inside of a
2258    type declaration or a module.  */
2259
2260 match
2261 gfc_match_private (gfc_statement * st)
2262 {
2263
2264   if (gfc_match ("private") != MATCH_YES)
2265     return MATCH_NO;
2266
2267   if (gfc_current_state () == COMP_DERIVED)
2268     {
2269       if (gfc_match_eos () == MATCH_YES)
2270         {
2271           *st = ST_PRIVATE;
2272           return MATCH_YES;
2273         }
2274
2275       gfc_syntax_error (ST_PRIVATE);
2276       return MATCH_ERROR;
2277     }
2278
2279   if (gfc_match_eos () == MATCH_YES)
2280     {
2281       *st = ST_PRIVATE;
2282       return MATCH_YES;
2283     }
2284
2285   *st = ST_ATTR_DECL;
2286   return access_attr_decl (ST_PRIVATE);
2287 }
2288
2289
2290 match
2291 gfc_match_public (gfc_statement * st)
2292 {
2293
2294   if (gfc_match ("public") != MATCH_YES)
2295     return MATCH_NO;
2296
2297   if (gfc_match_eos () == MATCH_YES)
2298     {
2299       *st = ST_PUBLIC;
2300       return MATCH_YES;
2301     }
2302
2303   *st = ST_ATTR_DECL;
2304   return access_attr_decl (ST_PUBLIC);
2305 }
2306
2307
2308 /* Workhorse for gfc_match_parameter.  */
2309
2310 static match
2311 do_parm (void)
2312 {
2313   gfc_symbol *sym;
2314   gfc_expr *init;
2315   match m;
2316
2317   m = gfc_match_symbol (&sym, 0);
2318   if (m == MATCH_NO)
2319     gfc_error ("Expected variable name at %C in PARAMETER statement");
2320
2321   if (m != MATCH_YES)
2322     return m;
2323
2324   if (gfc_match_char ('=') == MATCH_NO)
2325     {
2326       gfc_error ("Expected = sign in PARAMETER statement at %C");
2327       return MATCH_ERROR;
2328     }
2329
2330   m = gfc_match_init_expr (&init);
2331   if (m == MATCH_NO)
2332     gfc_error ("Expected expression at %C in PARAMETER statement");
2333   if (m != MATCH_YES)
2334     return m;
2335
2336   if (sym->ts.type == BT_UNKNOWN
2337       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2338     {
2339       m = MATCH_ERROR;
2340       goto cleanup;
2341     }
2342
2343   if (gfc_check_assign_symbol (sym, init) == FAILURE
2344       || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
2345     {
2346       m = MATCH_ERROR;
2347       goto cleanup;
2348     }
2349
2350   sym->value = init;
2351   return MATCH_YES;
2352
2353 cleanup:
2354   gfc_free_expr (init);
2355   return m;
2356 }
2357
2358
2359 /* Match a parameter statement, with the weird syntax that these have.  */
2360
2361 match
2362 gfc_match_parameter (void)
2363 {
2364   match m;
2365
2366   if (gfc_match_char ('(') == MATCH_NO)
2367     return MATCH_NO;
2368
2369   for (;;)
2370     {
2371       m = do_parm ();
2372       if (m != MATCH_YES)
2373         break;
2374
2375       if (gfc_match (" )%t") == MATCH_YES)
2376         break;
2377
2378       if (gfc_match_char (',') != MATCH_YES)
2379         {
2380           gfc_error ("Unexpected characters in PARAMETER statement at %C");
2381           m = MATCH_ERROR;
2382           break;
2383         }
2384     }
2385
2386   return m;
2387 }
2388
2389
2390 /* Save statements have a special syntax.  */
2391
2392 match
2393 gfc_match_save (void)
2394 {
2395   gfc_symbol *sym;
2396   match m;
2397
2398   if (gfc_match_eos () == MATCH_YES)
2399     {
2400       if (gfc_current_ns->seen_save)
2401         {
2402           gfc_error ("Blanket SAVE statement at %C follows previous "
2403                      "SAVE statement");
2404
2405           return MATCH_ERROR;
2406         }
2407
2408       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
2409       return MATCH_YES;
2410     }
2411
2412   if (gfc_current_ns->save_all)
2413     {
2414       gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2415       return MATCH_ERROR;
2416     }
2417
2418   gfc_match (" ::");
2419
2420   for (;;)
2421     {
2422       m = gfc_match_symbol (&sym, 0);
2423       switch (m)
2424         {
2425         case MATCH_YES:
2426           if (gfc_add_save (&sym->attr, gfc_current_locus ()) == FAILURE)
2427             return MATCH_ERROR;
2428           goto next_item;
2429
2430         case MATCH_NO:
2431           break;
2432
2433         case MATCH_ERROR:
2434           return MATCH_ERROR;
2435         }
2436
2437       m = gfc_match (" / %s /", &sym);
2438       if (m == MATCH_ERROR)
2439         return MATCH_ERROR;
2440       if (m == MATCH_NO)
2441         goto syntax;
2442
2443       if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE)
2444         return MATCH_ERROR;
2445       gfc_current_ns->seen_save = 1;
2446
2447     next_item:
2448       if (gfc_match_eos () == MATCH_YES)
2449         break;
2450       if (gfc_match_char (',') != MATCH_YES)
2451         goto syntax;
2452     }
2453
2454   return MATCH_YES;
2455
2456 syntax:
2457   gfc_error ("Syntax error in SAVE statement at %C");
2458   return MATCH_ERROR;
2459 }
2460
2461
2462 /* Match a module procedure statement.  Note that we have to modify
2463    symbols in the parent's namespace because the current one was there
2464    to receive symbols that are in a interface's formal argument list.  */
2465
2466 match
2467 gfc_match_modproc (void)
2468 {
2469   char name[GFC_MAX_SYMBOL_LEN + 1];
2470   gfc_symbol *sym;
2471   match m;
2472
2473   if (gfc_state_stack->state != COMP_INTERFACE
2474       || gfc_state_stack->previous == NULL
2475       || current_interface.type == INTERFACE_NAMELESS)
2476     {
2477       gfc_error
2478         ("MODULE PROCEDURE at %C must be in a generic module interface");
2479       return MATCH_ERROR;
2480     }
2481
2482   for (;;)
2483     {
2484       m = gfc_match_name (name);
2485       if (m == MATCH_NO)
2486         goto syntax;
2487       if (m != MATCH_YES)
2488         return MATCH_ERROR;
2489
2490       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
2491         return MATCH_ERROR;
2492
2493       if (sym->attr.proc != PROC_MODULE
2494           && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
2495         return MATCH_ERROR;
2496
2497       if (gfc_add_interface (sym) == FAILURE)
2498         return MATCH_ERROR;
2499
2500       if (gfc_match_eos () == MATCH_YES)
2501         break;
2502       if (gfc_match_char (',') != MATCH_YES)
2503         goto syntax;
2504     }
2505
2506   return MATCH_YES;
2507
2508 syntax:
2509   gfc_syntax_error (ST_MODULE_PROC);
2510   return MATCH_ERROR;
2511 }
2512
2513
2514 /* Match the beginning of a derived type declaration.  If a type name
2515    was the result of a function, then it is possible to have a symbol
2516    already to be known as a derived type yet have no components.  */
2517
2518 match
2519 gfc_match_derived_decl (void)
2520 {
2521   char name[GFC_MAX_SYMBOL_LEN + 1];
2522   symbol_attribute attr;
2523   gfc_symbol *sym;
2524   match m;
2525
2526   if (gfc_current_state () == COMP_DERIVED)
2527     return MATCH_NO;
2528
2529   gfc_clear_attr (&attr);
2530
2531 loop:
2532   if (gfc_match (" , private") == MATCH_YES)
2533     {
2534       if (gfc_find_state (COMP_MODULE) == FAILURE)
2535         {
2536           gfc_error
2537             ("Derived type at %C can only be PRIVATE within a MODULE");
2538           return MATCH_ERROR;
2539         }
2540
2541       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
2542         return MATCH_ERROR;
2543       goto loop;
2544     }
2545
2546   if (gfc_match (" , public") == MATCH_YES)
2547     {
2548       if (gfc_find_state (COMP_MODULE) == FAILURE)
2549         {
2550           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2551           return MATCH_ERROR;
2552         }
2553
2554       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
2555         return MATCH_ERROR;
2556       goto loop;
2557     }
2558
2559   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
2560     {
2561       gfc_error ("Expected :: in TYPE definition at %C");
2562       return MATCH_ERROR;
2563     }
2564
2565   m = gfc_match (" %n%t", name);
2566   if (m != MATCH_YES)
2567     return m;
2568
2569   /* Make sure the name isn't the name of an intrinsic type.  The
2570      'double precision' type doesn't get past the name matcher.  */
2571   if (strcmp (name, "integer") == 0
2572       || strcmp (name, "real") == 0
2573       || strcmp (name, "character") == 0
2574       || strcmp (name, "logical") == 0
2575       || strcmp (name, "complex") == 0)
2576     {
2577       gfc_error
2578         ("Type name '%s' at %C cannot be the same as an intrinsic type",
2579          name);
2580       return MATCH_ERROR;
2581     }
2582
2583   if (gfc_get_symbol (name, NULL, &sym))
2584     return MATCH_ERROR;
2585
2586   if (sym->ts.type != BT_UNKNOWN)
2587     {
2588       gfc_error ("Derived type name '%s' at %C already has a basic type "
2589                  "of %s", sym->name, gfc_typename (&sym->ts));
2590       return MATCH_ERROR;
2591     }
2592
2593   /* The symbol may already have the derived attribute without the
2594      components.  The ways this can happen is via a function
2595      definition, an INTRINSIC statement or a subtype in another
2596      derived type that is a pointer.  The first part of the AND clause
2597      is true if a the symbol is not the return value of a function. */
2598   if (sym->attr.flavor != FL_DERIVED
2599       && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
2600     return MATCH_ERROR;
2601
2602   if (sym->components != NULL)
2603     {
2604       gfc_error
2605         ("Derived type definition of '%s' at %C has already been defined",
2606          sym->name);
2607       return MATCH_ERROR;
2608     }
2609
2610   if (attr.access != ACCESS_UNKNOWN
2611       && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
2612     return MATCH_ERROR;
2613
2614   gfc_new_block = sym;
2615
2616   return MATCH_YES;
2617 }