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_current_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   int c;
 888
 889   gfc_clear_ts (ts);
 890
 891   if (gfc_match (" integer") == MATCH_YES)
 892     {
 893       ts->type = BT_INTEGER;
 894       ts->kind = gfc_default_integer_kind ();
 895       goto get_kind;
 896     }
 897
 898   if (gfc_match (" character") == MATCH_YES)
 899     {
 900       ts->type = BT_CHARACTER;
 901       return match_char_spec (ts);
 902     }
 903
 904   if (gfc_match (" real") == MATCH_YES)
 905     {
 906       ts->type = BT_REAL;
 907       ts->kind = gfc_default_real_kind ();
 908       goto get_kind;
 909     }
 910
 911   if (gfc_match (" double precision") == MATCH_YES)
 912     {
 913       ts->type = BT_REAL;
 914       ts->kind = gfc_default_double_kind ();
 915       return MATCH_YES;
 916     }
 917
 918   if (gfc_match (" complex") == MATCH_YES)
 919     {
 920       ts->type = BT_COMPLEX;
 921       ts->kind = gfc_default_complex_kind ();
 922       goto get_kind;
 923     }
 924
 925   if (gfc_match (" double complex") == MATCH_YES)
 926     {
 927       ts->type = BT_COMPLEX;
 928       ts->kind = gfc_default_double_kind ();
 929       return MATCH_YES;
 930     }
 931
 932   if (gfc_match (" logical") == MATCH_YES)
 933     {
 934       ts->type = BT_LOGICAL;
 935       ts->kind = gfc_default_logical_kind ();
 936       goto get_kind;
 937     }
 938
 939   m = gfc_match (" type ( %n )", name);
 940   if (m != MATCH_YES)
 941     return m;
 942
 943   /* Search for the name but allow the components to be defined later.  */
 944   if (gfc_get_ha_symbol (name, &sym))
 945     {
 946       gfc_error ("Type name '%s' at %C is ambiguous", name);
 947       return MATCH_ERROR;
 948     }
 949
 950   if (sym->attr.flavor != FL_DERIVED
 951       && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
 952     return MATCH_ERROR;
 953
 954   ts->type = BT_DERIVED;
 955   ts->kind = 0;
 956   ts->derived = sym;
 957
 958   return MATCH_YES;
 959
 960 get_kind:
 961   /* For all types except double, derived and character, look for an
 962      optional kind specifier.  MATCH_NO is actually OK at this point.  */
 963   if (kind_flag == 0)
 964     return MATCH_YES;
 965
 966   if (gfc_current_form == FORM_FREE)
 967     {
 968       c = gfc_peek_char();
 969       if (!gfc_is_whitespace(c) && c != '*' && c != '('
 970          && c != ':' && c != ',')
 971        return MATCH_NO;
 972     }
 973
 974   m = gfc_match_kind_spec (ts);
 975   if (m == MATCH_NO && ts->type != BT_CHARACTER)
 976     m = gfc_match_old_kind_spec (ts);
 977
 978   if (m == MATCH_NO)
 979     m = MATCH_YES;              /* No kind specifier found.  */
 980
 981   return m;
 982 }
 983
 984
 985 /* Matches an attribute specification including array specs.  If
 986    successful, leaves the variables current_attr and current_as
 987    holding the specification.  Also sets the colon_seen variable for
 988    later use by matchers associated with initializations.
 989
 990    This subroutine is a little tricky in the sense that we don't know
 991    if we really have an attr-spec until we hit the double colon.
 992    Until that time, we can only return MATCH_NO.  This forces us to
 993    check for duplicate specification at this level.  */
 994
 995 static match
 996 match_attr_spec (void)
 997 {
 998
 999   /* Modifiers that can exist in a type statement.  */
1000   typedef enum
1001   { GFC_DECL_BEGIN = 0,
1002     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1003     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1004     DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1005     DECL_TARGET, DECL_COLON, DECL_NONE,
1006     GFC_DECL_END /* Sentinel */
1007   }
1008   decl_types;
1009
1010 /* GFC_DECL_END is the sentinel, index starts at 0.  */
1011 #define NUM_DECL GFC_DECL_END
1012
1013   static mstring decls[] = {
1014     minit (", allocatable", DECL_ALLOCATABLE),
1015     minit (", dimension", DECL_DIMENSION),
1016     minit (", external", DECL_EXTERNAL),
1017     minit (", intent ( in )", DECL_IN),
1018     minit (", intent ( out )", DECL_OUT),
1019     minit (", intent ( in out )", DECL_INOUT),
1020     minit (", intrinsic", DECL_INTRINSIC),
1021     minit (", optional", DECL_OPTIONAL),
1022     minit (", parameter", DECL_PARAMETER),
1023     minit (", pointer", DECL_POINTER),
1024     minit (", private", DECL_PRIVATE),
1025     minit (", public", DECL_PUBLIC),
1026     minit (", save", DECL_SAVE),
1027     minit (", target", DECL_TARGET),
1028     minit ("::", DECL_COLON),
1029     minit (NULL, DECL_NONE)
1030   };
1031
1032   locus start, seen_at[NUM_DECL];
1033   int seen[NUM_DECL];
1034   decl_types d;
1035   const char *attr;
1036   match m;
1037   try t;
1038
1039   gfc_clear_attr (&current_attr);
1040   start = gfc_current_locus;
1041
1042   current_as = NULL;
1043   colon_seen = 0;
1044
1045   /* See if we get all of the keywords up to the final double colon.  */
1046   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1047     seen[d] = 0;
1048
1049   for (;;)
1050     {
1051       d = (decl_types) gfc_match_strings (decls);
1052       if (d == DECL_NONE || d == DECL_COLON)
1053         break;
1054
1055       seen[d]++;
1056       seen_at[d] = gfc_current_locus;
1057
1058       if (d == DECL_DIMENSION)
1059         {
1060           m = gfc_match_array_spec (&current_as);
1061
1062           if (m == MATCH_NO)
1063             {
1064               gfc_error ("Missing dimension specification at %C");
1065               m = MATCH_ERROR;
1066             }
1067
1068           if (m == MATCH_ERROR)
1069             goto cleanup;
1070         }
1071     }
1072
1073   /* No double colon, so assume that we've been looking at something
1074      else the whole time.  */
1075   if (d == DECL_NONE)
1076     {
1077       m = MATCH_NO;
1078       goto cleanup;
1079     }
1080
1081   /* Since we've seen a double colon, we have to be looking at an
1082      attr-spec.  This means that we can now issue errors.  */
1083   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1084     if (seen[d] > 1)
1085       {
1086         switch (d)
1087           {
1088           case DECL_ALLOCATABLE:
1089             attr = "ALLOCATABLE";
1090             break;
1091           case DECL_DIMENSION:
1092             attr = "DIMENSION";
1093             break;
1094           case DECL_EXTERNAL:
1095             attr = "EXTERNAL";
1096             break;
1097           case DECL_IN:
1098             attr = "INTENT (IN)";
1099             break;
1100           case DECL_OUT:
1101             attr = "INTENT (OUT)";
1102             break;
1103           case DECL_INOUT:
1104             attr = "INTENT (IN OUT)";
1105             break;
1106           case DECL_INTRINSIC:
1107             attr = "INTRINSIC";
1108             break;
1109           case DECL_OPTIONAL:
1110             attr = "OPTIONAL";
1111             break;
1112           case DECL_PARAMETER:
1113             attr = "PARAMETER";
1114             break;
1115           case DECL_POINTER:
1116             attr = "POINTER";
1117             break;
1118           case DECL_PRIVATE:
1119             attr = "PRIVATE";
1120             break;
1121           case DECL_PUBLIC:
1122             attr = "PUBLIC";
1123             break;
1124           case DECL_SAVE:
1125             attr = "SAVE";
1126             break;
1127           case DECL_TARGET:
1128             attr = "TARGET";
1129             break;
1130           default:
1131             attr = NULL;        /* This shouldn't happen */
1132           }
1133
1134         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1135         m = MATCH_ERROR;
1136         goto cleanup;
1137       }
1138
1139   /* Now that we've dealt with duplicate attributes, add the attributes
1140      to the current attribute.  */
1141   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1142     {
1143       if (seen[d] == 0)
1144         continue;
1145
1146       if (gfc_current_state () == COMP_DERIVED
1147           && d != DECL_DIMENSION && d != DECL_POINTER
1148           && d != DECL_COLON && d != DECL_NONE)
1149         {
1150
1151           gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1152                      &seen_at[d]);
1153           m = MATCH_ERROR;
1154           goto cleanup;
1155         }
1156
1157       switch (d)
1158         {
1159         case DECL_ALLOCATABLE:
1160           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
1161           break;
1162
1163         case DECL_DIMENSION:
1164           t = gfc_add_dimension (&current_attr, &seen_at[d]);
1165           break;
1166
1167         case DECL_EXTERNAL:
1168           t = gfc_add_external (&current_attr, &seen_at[d]);
1169           break;
1170
1171         case DECL_IN:
1172           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
1173           break;
1174
1175         case DECL_OUT:
1176           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
1177           break;
1178
1179         case DECL_INOUT:
1180           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
1181           break;
1182
1183         case DECL_INTRINSIC:
1184           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
1185           break;
1186
1187         case DECL_OPTIONAL:
1188           t = gfc_add_optional (&current_attr, &seen_at[d]);
1189           break;
1190
1191         case DECL_PARAMETER:
1192           t = gfc_add_flavor (&current_attr, FL_PARAMETER, &seen_at[d]);
1193           break;
1194
1195         case DECL_POINTER:
1196           t = gfc_add_pointer (&current_attr, &seen_at[d]);
1197           break;
1198
1199         case DECL_PRIVATE:
1200           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, &seen_at[d]);
1201           break;
1202
1203         case DECL_PUBLIC:
1204           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, &seen_at[d]);
1205           break;
1206
1207         case DECL_SAVE:
1208           t = gfc_add_save (&current_attr, &seen_at[d]);
1209           break;
1210
1211         case DECL_TARGET:
1212           t = gfc_add_target (&current_attr, &seen_at[d]);
1213           break;
1214
1215         default:
1216           gfc_internal_error ("match_attr_spec(): Bad attribute");
1217         }
1218
1219       if (t == FAILURE)
1220         {
1221           m = MATCH_ERROR;
1222           goto cleanup;
1223         }
1224     }
1225
1226   colon_seen = 1;
1227   return MATCH_YES;
1228
1229 cleanup:
1230   gfc_current_locus = start;
1231   gfc_free_array_spec (current_as);
1232   current_as = NULL;
1233   return m;
1234 }
1235
1236
1237 /* Match a data declaration statement.  */
1238
1239 match
1240 gfc_match_data_decl (void)
1241 {
1242   gfc_symbol *sym;
1243   match m;
1244
1245   m = gfc_match_type_spec (&current_ts, 1);
1246   if (m != MATCH_YES)
1247     return m;
1248
1249   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
1250     {
1251       sym = gfc_use_derived (current_ts.derived);
1252
1253       if (sym == NULL)
1254         {
1255           m = MATCH_ERROR;
1256           goto cleanup;
1257         }
1258
1259       current_ts.derived = sym;
1260     }
1261
1262   m = match_attr_spec ();
1263   if (m == MATCH_ERROR)
1264     {
1265       m = MATCH_NO;
1266       goto cleanup;
1267     }
1268
1269   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
1270     {
1271
1272       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
1273         goto ok;
1274
1275       if (gfc_find_symbol (current_ts.derived->name,
1276                            current_ts.derived->ns->parent, 1, &sym) == 0)
1277         goto ok;
1278
1279       /* Hope that an ambiguous symbol is itself masked by a type definition.  */
1280       if (sym != NULL && sym->attr.flavor == FL_DERIVED)
1281         goto ok;
1282
1283       gfc_error ("Derived type at %C has not been previously defined");
1284       m = MATCH_ERROR;
1285       goto cleanup;
1286     }
1287
1288 ok:
1289   /* If we have an old-style character declaration, and no new-style
1290      attribute specifications, then there a comma is optional between
1291      the type specification and the variable list.  */
1292   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
1293     gfc_match_char (',');
1294
1295   /* Give the types/attributes to symbols that follow.  */
1296   for (;;)
1297     {
1298       m = variable_decl ();
1299       if (m == MATCH_ERROR)
1300         goto cleanup;
1301       if (m == MATCH_NO)
1302         break;
1303
1304       if (gfc_match_eos () == MATCH_YES)
1305         goto cleanup;
1306       if (gfc_match_char (',') != MATCH_YES)
1307         break;
1308     }
1309
1310   gfc_error ("Syntax error in data declaration at %C");
1311   m = MATCH_ERROR;
1312
1313 cleanup:
1314   gfc_free_array_spec (current_as);
1315   current_as = NULL;
1316   return m;
1317 }
1318
1319
1320 /* Match a prefix associated with a function or subroutine
1321    declaration.  If the typespec pointer is nonnull, then a typespec
1322    can be matched.  Note that if nothing matches, MATCH_YES is
1323    returned (the null string was matched).  */
1324
1325 static match
1326 match_prefix (gfc_typespec * ts)
1327 {
1328   int seen_type;
1329
1330   gfc_clear_attr (&current_attr);
1331   seen_type = 0;
1332
1333 loop:
1334   if (!seen_type && ts != NULL
1335       && gfc_match_type_spec (ts, 1) == MATCH_YES
1336       && gfc_match_space () == MATCH_YES)
1337     {
1338
1339       seen_type = 1;
1340       goto loop;
1341     }
1342
1343   if (gfc_match ("elemental% ") == MATCH_YES)
1344     {
1345       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
1346         return MATCH_ERROR;
1347
1348       goto loop;
1349     }
1350
1351   if (gfc_match ("pure% ") == MATCH_YES)
1352     {
1353       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
1354         return MATCH_ERROR;
1355
1356       goto loop;
1357     }
1358
1359   if (gfc_match ("recursive% ") == MATCH_YES)
1360     {
1361       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
1362         return MATCH_ERROR;
1363
1364       goto loop;
1365     }
1366
1367   /* At this point, the next item is not a prefix.  */
1368   return MATCH_YES;
1369 }
1370
1371
1372 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
1373
1374 static try
1375 copy_prefix (symbol_attribute * dest, locus * where)
1376 {
1377
1378   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
1379     return FAILURE;
1380
1381   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
1382     return FAILURE;
1383
1384   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
1385     return FAILURE;
1386
1387   return SUCCESS;
1388 }
1389
1390
1391 /* Match a formal argument list.  */
1392
1393 match
1394 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
1395 {
1396   gfc_formal_arglist *head, *tail, *p, *q;
1397   char name[GFC_MAX_SYMBOL_LEN + 1];
1398   gfc_symbol *sym;
1399   match m;
1400
1401   head = tail = NULL;
1402
1403   if (gfc_match_char ('(') != MATCH_YES)
1404     {
1405       if (null_flag)
1406         goto ok;
1407       return MATCH_NO;
1408     }
1409
1410   if (gfc_match_char (')') == MATCH_YES)
1411     goto ok;
1412
1413   for (;;)
1414     {
1415       if (gfc_match_char ('*') == MATCH_YES)
1416         sym = NULL;
1417       else
1418         {
1419           m = gfc_match_name (name);
1420           if (m != MATCH_YES)
1421             goto cleanup;
1422
1423           if (gfc_get_symbol (name, NULL, &sym))
1424             goto cleanup;
1425         }
1426
1427       p = gfc_get_formal_arglist ();
1428
1429       if (head == NULL)
1430         head = tail = p;
1431       else
1432         {
1433           tail->next = p;
1434           tail = p;
1435         }
1436
1437       tail->sym = sym;
1438
1439       /* We don't add the VARIABLE flavor because the name could be a
1440          dummy procedure.  We don't apply these attributes to formal
1441          arguments of statement functions.  */
1442       if (sym != NULL && !st_flag
1443           && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
1444               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
1445         {
1446           m = MATCH_ERROR;
1447           goto cleanup;
1448         }
1449
1450       /* The name of a program unit can be in a different namespace,
1451          so check for it explicitly.  After the statement is accepted,
1452          the name is checked for especially in gfc_get_symbol().  */
1453       if (gfc_new_block != NULL && sym != NULL
1454           && strcmp (sym->name, gfc_new_block->name) == 0)
1455         {
1456           gfc_error ("Name '%s' at %C is the name of the procedure",
1457                      sym->name);
1458           m = MATCH_ERROR;
1459           goto cleanup;
1460         }
1461
1462       if (gfc_match_char (')') == MATCH_YES)
1463         goto ok;
1464
1465       m = gfc_match_char (',');
1466       if (m != MATCH_YES)
1467         {
1468           gfc_error ("Unexpected junk in formal argument list at %C");
1469           goto cleanup;
1470         }
1471     }
1472
1473 ok:
1474   /* Check for duplicate symbols in the formal argument list.  */
1475   if (head != NULL)
1476     {
1477       for (p = head; p->next; p = p->next)
1478         {
1479           if (p->sym == NULL)
1480             continue;
1481
1482           for (q = p->next; q; q = q->next)
1483             if (p->sym == q->sym)
1484               {
1485                 gfc_error
1486                   ("Duplicate symbol '%s' in formal argument list at %C",
1487                    p->sym->name);
1488
1489                 m = MATCH_ERROR;
1490                 goto cleanup;
1491               }
1492         }
1493     }
1494
1495   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
1496       FAILURE)
1497     {
1498       m = MATCH_ERROR;
1499       goto cleanup;
1500     }
1501
1502   return MATCH_YES;
1503
1504 cleanup:
1505   gfc_free_formal_arglist (head);
1506   return m;
1507 }
1508
1509
1510 /* Match a RESULT specification following a function declaration or
1511    ENTRY statement.  Also matches the end-of-statement.  */
1512
1513 static match
1514 match_result (gfc_symbol * function, gfc_symbol ** result)
1515 {
1516   char name[GFC_MAX_SYMBOL_LEN + 1];
1517   gfc_symbol *r;
1518   match m;
1519
1520   if (gfc_match (" result (") != MATCH_YES)
1521     return MATCH_NO;
1522
1523   m = gfc_match_name (name);
1524   if (m != MATCH_YES)
1525     return m;
1526
1527   if (gfc_match (" )%t") != MATCH_YES)
1528     {
1529       gfc_error ("Unexpected junk following RESULT variable at %C");
1530       return MATCH_ERROR;
1531     }
1532
1533   if (strcmp (function->name, name) == 0)
1534     {
1535       gfc_error
1536         ("RESULT variable at %C must be different than function name");
1537       return MATCH_ERROR;
1538     }
1539
1540   if (gfc_get_symbol (name, NULL, &r))
1541     return MATCH_ERROR;
1542
1543   if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
1544       || gfc_add_result (&r->attr, NULL) == FAILURE)
1545     return MATCH_ERROR;
1546
1547   *result = r;
1548
1549   return MATCH_YES;
1550 }
1551
1552
1553 /* Match a function declaration.  */
1554
1555 match
1556 gfc_match_function_decl (void)
1557 {
1558   char name[GFC_MAX_SYMBOL_LEN + 1];
1559   gfc_symbol *sym, *result;
1560   locus old_loc;
1561   match m;
1562
1563   if (gfc_current_state () != COMP_NONE
1564       && gfc_current_state () != COMP_INTERFACE
1565       && gfc_current_state () != COMP_CONTAINS)
1566     return MATCH_NO;
1567
1568   gfc_clear_ts (&current_ts);
1569
1570   old_loc = gfc_current_locus;
1571
1572   m = match_prefix (&current_ts);
1573   if (m != MATCH_YES)
1574     {
1575       gfc_current_locus = old_loc;
1576       return m;
1577     }
1578
1579   if (gfc_match ("function% %n", name) != MATCH_YES)
1580     {
1581       gfc_current_locus = old_loc;
1582       return MATCH_NO;
1583     }
1584
1585   if (get_proc_name (name, &sym))
1586     return MATCH_ERROR;
1587   gfc_new_block = sym;
1588
1589   m = gfc_match_formal_arglist (sym, 0, 0);
1590   if (m == MATCH_NO)
1591     gfc_error ("Expected formal argument list in function definition at %C");
1592   else if (m == MATCH_ERROR)
1593     goto cleanup;
1594
1595   result = NULL;
1596
1597   if (gfc_match_eos () != MATCH_YES)
1598     {
1599       /* See if a result variable is present.  */
1600       m = match_result (sym, &result);
1601       if (m == MATCH_NO)
1602         gfc_error ("Unexpected junk after function declaration at %C");
1603
1604       if (m != MATCH_YES)
1605         {
1606           m = MATCH_ERROR;
1607           goto cleanup;
1608         }
1609     }
1610
1611   /* Make changes to the symbol.  */
1612   m = MATCH_ERROR;
1613
1614   if (gfc_add_function (&sym->attr, NULL) == FAILURE)
1615     goto cleanup;
1616
1617   if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
1618       || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1619     goto cleanup;
1620
1621   if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
1622     {
1623       gfc_error ("Function '%s' at %C already has a type of %s", name,
1624                  gfc_basic_typename (sym->ts.type));
1625       goto cleanup;
1626     }
1627
1628   if (result == NULL)
1629     {
1630       sym->ts = current_ts;
1631       sym->result = sym;
1632     }
1633   else
1634     {
1635       result->ts = current_ts;
1636       sym->result = result;
1637     }
1638
1639   return MATCH_YES;
1640
1641 cleanup:
1642   gfc_current_locus = old_loc;
1643   return m;
1644 }
1645
1646
1647 /* Match an ENTRY statement.  */
1648
1649 match
1650 gfc_match_entry (void)
1651 {
1652   gfc_symbol *function, *result, *entry;
1653   char name[GFC_MAX_SYMBOL_LEN + 1];
1654   gfc_compile_state state;
1655   match m;
1656
1657   m = gfc_match_name (name);
1658   if (m != MATCH_YES)
1659     return m;
1660
1661   if (get_proc_name (name, &entry))
1662     return MATCH_ERROR;
1663
1664   gfc_enclosing_unit (&state);
1665   switch (state)
1666     {
1667     case COMP_SUBROUTINE:
1668       m = gfc_match_formal_arglist (entry, 0, 1);
1669       if (m != MATCH_YES)
1670         return MATCH_ERROR;
1671
1672       if (gfc_current_state () != COMP_SUBROUTINE)
1673         goto exec_construct;
1674
1675       if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1676           || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
1677         return MATCH_ERROR;
1678
1679       break;
1680
1681     case COMP_FUNCTION:
1682       m = gfc_match_formal_arglist (entry, 0, 0);
1683       if (m != MATCH_YES)
1684         return MATCH_ERROR;
1685
1686       if (gfc_current_state () != COMP_FUNCTION)
1687         goto exec_construct;
1688       function = gfc_state_stack->sym;
1689
1690       result = NULL;
1691
1692       if (gfc_match_eos () == MATCH_YES)
1693         {
1694           if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1695               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1696             return MATCH_ERROR;
1697
1698           entry->result = function->result;
1699
1700         }
1701       else
1702         {
1703           m = match_result (function, &result);
1704           if (m == MATCH_NO)
1705             gfc_syntax_error (ST_ENTRY);
1706           if (m != MATCH_YES)
1707             return MATCH_ERROR;
1708
1709           if (gfc_add_result (&result->attr, NULL) == FAILURE
1710               || gfc_add_entry (&entry->attr, NULL) == FAILURE
1711               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1712             return MATCH_ERROR;
1713         }
1714
1715       if (function->attr.recursive && result == NULL)
1716         {
1717           gfc_error ("RESULT attribute required in ENTRY statement at %C");
1718           return MATCH_ERROR;
1719         }
1720
1721       break;
1722
1723     default:
1724       goto exec_construct;
1725     }
1726
1727   if (gfc_match_eos () != MATCH_YES)
1728     {
1729       gfc_syntax_error (ST_ENTRY);
1730       return MATCH_ERROR;
1731     }
1732
1733   return MATCH_YES;
1734
1735 exec_construct:
1736   gfc_error ("ENTRY statement at %C cannot appear within %s",
1737              gfc_state_name (gfc_current_state ()));
1738
1739   return MATCH_ERROR;
1740 }
1741
1742
1743 /* Match a subroutine statement, including optional prefixes.  */
1744
1745 match
1746 gfc_match_subroutine (void)
1747 {
1748   char name[GFC_MAX_SYMBOL_LEN + 1];
1749   gfc_symbol *sym;
1750   match m;
1751
1752   if (gfc_current_state () != COMP_NONE
1753       && gfc_current_state () != COMP_INTERFACE
1754       && gfc_current_state () != COMP_CONTAINS)
1755     return MATCH_NO;
1756
1757   m = match_prefix (NULL);
1758   if (m != MATCH_YES)
1759     return m;
1760
1761   m = gfc_match ("subroutine% %n", name);
1762   if (m != MATCH_YES)
1763     return m;
1764
1765   if (get_proc_name (name, &sym))
1766     return MATCH_ERROR;
1767   gfc_new_block = sym;
1768
1769   if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1770     return MATCH_ERROR;
1771
1772   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
1773     return MATCH_ERROR;
1774
1775   if (gfc_match_eos () != MATCH_YES)
1776     {
1777       gfc_syntax_error (ST_SUBROUTINE);
1778       return MATCH_ERROR;
1779     }
1780
1781   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1782     return MATCH_ERROR;
1783
1784   return MATCH_YES;
1785 }
1786
1787
1788 /* Return nonzero if we're currenly compiling a contained procedure.  */
1789
1790 static int
1791 contained_procedure (void)
1792 {
1793   gfc_state_data *s;
1794
1795   for (s=gfc_state_stack; s; s=s->previous)
1796     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
1797        && s->previous != NULL
1798        && s->previous->state == COMP_CONTAINS)
1799       return 1;
1800
1801   return 0;
1802 }
1803
1804 /* Match any of the various end-block statements.  Returns the type of
1805    END to the caller.  The END INTERFACE, END IF, END DO and END
1806    SELECT statements cannot be replaced by a single END statement.  */
1807
1808 match
1809 gfc_match_end (gfc_statement * st)
1810 {
1811   char name[GFC_MAX_SYMBOL_LEN + 1];
1812   gfc_compile_state state;
1813   locus old_loc;
1814   const char *block_name;
1815   const char *target;
1816   int eos_ok;
1817   match m;
1818
1819   old_loc = gfc_current_locus;
1820   if (gfc_match ("end") != MATCH_YES)
1821     return MATCH_NO;
1822
1823   state = gfc_current_state ();
1824   block_name =
1825     gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
1826
1827   if (state == COMP_CONTAINS)
1828     {
1829       state = gfc_state_stack->previous->state;
1830       block_name = gfc_state_stack->previous->sym == NULL ? NULL
1831         : gfc_state_stack->previous->sym->name;
1832     }
1833
1834   switch (state)
1835     {
1836     case COMP_NONE:
1837     case COMP_PROGRAM:
1838       *st = ST_END_PROGRAM;
1839       target = " program";
1840       eos_ok = 1;
1841       break;
1842
1843     case COMP_SUBROUTINE:
1844       *st = ST_END_SUBROUTINE;
1845       target = " subroutine";
1846       eos_ok = !contained_procedure ();
1847       break;
1848
1849     case COMP_FUNCTION:
1850       *st = ST_END_FUNCTION;
1851       target = " function";
1852       eos_ok = !contained_procedure ();
1853       break;
1854
1855     case COMP_BLOCK_DATA:
1856       *st = ST_END_BLOCK_DATA;
1857       target = " block data";
1858       eos_ok = 1;
1859       break;
1860
1861     case COMP_MODULE:
1862       *st = ST_END_MODULE;
1863       target = " module";
1864       eos_ok = 1;
1865       break;
1866
1867     case COMP_INTERFACE:
1868       *st = ST_END_INTERFACE;
1869       target = " interface";
1870       eos_ok = 0;
1871       break;
1872
1873     case COMP_DERIVED:
1874       *st = ST_END_TYPE;
1875       target = " type";
1876       eos_ok = 0;
1877       break;
1878
1879     case COMP_IF:
1880       *st = ST_ENDIF;
1881       target = " if";
1882       eos_ok = 0;
1883       break;
1884
1885     case COMP_DO:
1886       *st = ST_ENDDO;
1887       target = " do";
1888       eos_ok = 0;
1889       break;
1890
1891     case COMP_SELECT:
1892       *st = ST_END_SELECT;
1893       target = " select";
1894       eos_ok = 0;
1895       break;
1896
1897     case COMP_FORALL:
1898       *st = ST_END_FORALL;
1899       target = " forall";
1900       eos_ok = 0;
1901       break;
1902
1903     case COMP_WHERE:
1904       *st = ST_END_WHERE;
1905       target = " where";
1906       eos_ok = 0;
1907       break;
1908
1909     default:
1910       gfc_error ("Unexpected END statement at %C");
1911       goto cleanup;
1912     }
1913
1914   if (gfc_match_eos () == MATCH_YES)
1915     {
1916       if (!eos_ok)
1917         {
1918           /* We would have required END [something]  */
1919           gfc_error ("%s statement expected at %C",
1920                      gfc_ascii_statement (*st));
1921           goto cleanup;
1922         }
1923
1924       return MATCH_YES;
1925     }
1926
1927   /* Verify that we've got the sort of end-block that we're expecting.  */
1928   if (gfc_match (target) != MATCH_YES)
1929     {
1930       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
1931       goto cleanup;
1932     }
1933
1934   /* If we're at the end, make sure a block name wasn't required.  */
1935   if (gfc_match_eos () == MATCH_YES)
1936     {
1937
1938       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
1939         return MATCH_YES;
1940
1941       if (gfc_current_block () == NULL)
1942         return MATCH_YES;
1943
1944       gfc_error ("Expected block name of '%s' in %s statement at %C",
1945                  block_name, gfc_ascii_statement (*st));
1946
1947       return MATCH_ERROR;
1948     }
1949
1950   /* END INTERFACE has a special handler for its several possible endings.  */
1951   if (*st == ST_END_INTERFACE)
1952     return gfc_match_end_interface ();
1953
1954   /* We haven't hit the end of statement, so what is left must be an end-name.  */
1955   m = gfc_match_space ();
1956   if (m == MATCH_YES)
1957     m = gfc_match_name (name);
1958
1959   if (m == MATCH_NO)
1960     gfc_error ("Expected terminating name at %C");
1961   if (m != MATCH_YES)
1962     goto cleanup;
1963
1964   if (block_name == NULL)
1965     goto syntax;
1966
1967   if (strcmp (name, block_name) != 0)
1968     {
1969       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
1970                  gfc_ascii_statement (*st));
1971       goto cleanup;
1972     }
1973
1974   if (gfc_match_eos () == MATCH_YES)
1975     return MATCH_YES;
1976
1977 syntax:
1978   gfc_syntax_error (*st);
1979
1980 cleanup:
1981   gfc_current_locus = old_loc;
1982   return MATCH_ERROR;
1983 }
1984
1985
1986
1987 /***************** Attribute declaration statements ****************/
1988
1989 /* Set the attribute of a single variable.  */
1990
1991 static match
1992 attr_decl1 (void)
1993 {
1994   char name[GFC_MAX_SYMBOL_LEN + 1];
1995   gfc_array_spec *as;
1996   gfc_symbol *sym;
1997   locus var_locus;
1998   match m;
1999
2000   as = NULL;
2001
2002   m = gfc_match_name (name);
2003   if (m != MATCH_YES)
2004     goto cleanup;
2005
2006   if (find_special (name, &sym))
2007     return MATCH_ERROR;
2008
2009   var_locus = gfc_current_locus;
2010
2011   /* Deal with possible array specification for certain attributes.  */
2012   if (current_attr.dimension
2013       || current_attr.allocatable
2014       || current_attr.pointer
2015       || current_attr.target)
2016     {
2017       m = gfc_match_array_spec (&as);
2018       if (m == MATCH_ERROR)
2019         goto cleanup;
2020
2021       if (current_attr.dimension && m == MATCH_NO)
2022         {
2023           gfc_error
2024             ("Missing array specification at %L in DIMENSION statement",
2025              &var_locus);
2026           m = MATCH_ERROR;
2027           goto cleanup;
2028         }
2029
2030       if ((current_attr.allocatable || current_attr.pointer)
2031           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2032         {
2033           gfc_error ("Array specification must be deferred at %L",
2034                      &var_locus);
2035           m = MATCH_ERROR;
2036           goto cleanup;
2037         }
2038     }
2039
2040   /* Update symbol table.  DIMENSION attribute is set in gfc_set_array_spec().  */
2041   if (current_attr.dimension == 0
2042       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2043     {
2044       m = MATCH_ERROR;
2045       goto cleanup;
2046     }
2047
2048   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2049     {
2050       m = MATCH_ERROR;
2051       goto cleanup;
2052     }
2053
2054   if ((current_attr.external || current_attr.intrinsic)
2055       && sym->attr.flavor != FL_PROCEDURE
2056       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
2057     {
2058       m = MATCH_ERROR;
2059       goto cleanup;
2060     }
2061
2062   return MATCH_YES;
2063
2064 cleanup:
2065   gfc_free_array_spec (as);
2066   return m;
2067 }
2068
2069
2070 /* Generic attribute declaration subroutine.  Used for attributes that
2071    just have a list of names.  */
2072
2073 static match
2074 attr_decl (void)
2075 {
2076   match m;
2077
2078   /* Gobble the optional double colon, by simply ignoring the result
2079      of gfc_match().  */
2080   gfc_match (" ::");
2081
2082   for (;;)
2083     {
2084       m = attr_decl1 ();
2085       if (m != MATCH_YES)
2086         break;
2087
2088       if (gfc_match_eos () == MATCH_YES)
2089         {
2090           m = MATCH_YES;
2091           break;
2092         }
2093
2094       if (gfc_match_char (',') != MATCH_YES)
2095         {
2096           gfc_error ("Unexpected character in variable list at %C");
2097           m = MATCH_ERROR;
2098           break;
2099         }
2100     }
2101
2102   return m;
2103 }
2104
2105
2106 match
2107 gfc_match_external (void)
2108 {
2109
2110   gfc_clear_attr (&current_attr);
2111   gfc_add_external (&current_attr, NULL);
2112
2113   return attr_decl ();
2114 }
2115
2116
2117
2118 match
2119 gfc_match_intent (void)
2120 {
2121   sym_intent intent;
2122
2123   intent = match_intent_spec ();
2124   if (intent == INTENT_UNKNOWN)
2125     return MATCH_ERROR;
2126
2127   gfc_clear_attr (&current_attr);
2128   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2129
2130   return attr_decl ();
2131 }
2132
2133
2134 match
2135 gfc_match_intrinsic (void)
2136 {
2137
2138   gfc_clear_attr (&current_attr);
2139   gfc_add_intrinsic (&current_attr, NULL);
2140
2141   return attr_decl ();
2142 }
2143
2144
2145 match
2146 gfc_match_optional (void)
2147 {
2148
2149   gfc_clear_attr (&current_attr);
2150   gfc_add_optional (&current_attr, NULL);
2151
2152   return attr_decl ();
2153 }
2154
2155
2156 match
2157 gfc_match_pointer (void)
2158 {
2159
2160   gfc_clear_attr (&current_attr);
2161   gfc_add_pointer (&current_attr, NULL);
2162
2163   return attr_decl ();
2164 }
2165
2166
2167 match
2168 gfc_match_allocatable (void)
2169 {
2170
2171   gfc_clear_attr (&current_attr);
2172   gfc_add_allocatable (&current_attr, NULL);
2173
2174   return attr_decl ();
2175 }
2176
2177
2178 match
2179 gfc_match_dimension (void)
2180 {
2181
2182   gfc_clear_attr (&current_attr);
2183   gfc_add_dimension (&current_attr, NULL);
2184
2185   return attr_decl ();
2186 }
2187
2188
2189 match
2190 gfc_match_target (void)
2191 {
2192
2193   gfc_clear_attr (&current_attr);
2194   gfc_add_target (&current_attr, NULL);
2195
2196   return attr_decl ();
2197 }
2198
2199
2200 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2201    statement.  */
2202
2203 static match
2204 access_attr_decl (gfc_statement st)
2205 {
2206   char name[GFC_MAX_SYMBOL_LEN + 1];
2207   interface_type type;
2208   gfc_user_op *uop;
2209   gfc_symbol *sym;
2210   gfc_intrinsic_op operator;
2211   match m;
2212
2213   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2214     goto done;
2215
2216   for (;;)
2217     {
2218       m = gfc_match_generic_spec (&type, name, &operator);
2219       if (m == MATCH_NO)
2220         goto syntax;
2221       if (m == MATCH_ERROR)
2222         return MATCH_ERROR;
2223
2224       switch (type)
2225         {
2226         case INTERFACE_NAMELESS:
2227           goto syntax;
2228
2229         case INTERFACE_GENERIC:
2230           if (gfc_get_symbol (name, NULL, &sym))
2231             goto done;
2232
2233           if (gfc_add_access (&sym->attr,
2234                               (st ==
2235                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2236                               NULL) == FAILURE)
2237             return MATCH_ERROR;
2238
2239           break;
2240
2241         case INTERFACE_INTRINSIC_OP:
2242           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2243             {
2244               gfc_current_ns->operator_access[operator] =
2245                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2246             }
2247           else
2248             {
2249               gfc_error ("Access specification of the %s operator at %C has "
2250                          "already been specified", gfc_op2string (operator));
2251               goto done;
2252             }
2253
2254           break;
2255
2256         case INTERFACE_USER_OP:
2257           uop = gfc_get_uop (name);
2258
2259           if (uop->access == ACCESS_UNKNOWN)
2260             {
2261               uop->access =
2262                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2263             }
2264           else
2265             {
2266               gfc_error
2267                 ("Access specification of the .%s. operator at %C has "
2268                  "already been specified", sym->name);
2269               goto done;
2270             }
2271
2272           break;
2273         }
2274
2275       if (gfc_match_char (',') == MATCH_NO)
2276         break;
2277     }
2278
2279   if (gfc_match_eos () != MATCH_YES)
2280     goto syntax;
2281   return MATCH_YES;
2282
2283 syntax:
2284   gfc_syntax_error (st);
2285
2286 done:
2287   return MATCH_ERROR;
2288 }
2289
2290
2291 /* The PRIVATE statement is a bit weird in that it can be a attribute
2292    declaration, but also works as a standlone statement inside of a
2293    type declaration or a module.  */
2294
2295 match
2296 gfc_match_private (gfc_statement * st)
2297 {
2298
2299   if (gfc_match ("private") != MATCH_YES)
2300     return MATCH_NO;
2301
2302   if (gfc_current_state () == COMP_DERIVED)
2303     {
2304       if (gfc_match_eos () == MATCH_YES)
2305         {
2306           *st = ST_PRIVATE;
2307           return MATCH_YES;
2308         }
2309
2310       gfc_syntax_error (ST_PRIVATE);
2311       return MATCH_ERROR;
2312     }
2313
2314   if (gfc_match_eos () == MATCH_YES)
2315     {
2316       *st = ST_PRIVATE;
2317       return MATCH_YES;
2318     }
2319
2320   *st = ST_ATTR_DECL;
2321   return access_attr_decl (ST_PRIVATE);
2322 }
2323
2324
2325 match
2326 gfc_match_public (gfc_statement * st)
2327 {
2328
2329   if (gfc_match ("public") != MATCH_YES)
2330     return MATCH_NO;
2331
2332   if (gfc_match_eos () == MATCH_YES)
2333     {
2334       *st = ST_PUBLIC;
2335       return MATCH_YES;
2336     }
2337
2338   *st = ST_ATTR_DECL;
2339   return access_attr_decl (ST_PUBLIC);
2340 }
2341
2342
2343 /* Workhorse for gfc_match_parameter.  */
2344
2345 static match
2346 do_parm (void)
2347 {
2348   gfc_symbol *sym;
2349   gfc_expr *init;
2350   match m;
2351
2352   m = gfc_match_symbol (&sym, 0);
2353   if (m == MATCH_NO)
2354     gfc_error ("Expected variable name at %C in PARAMETER statement");
2355
2356   if (m != MATCH_YES)
2357     return m;
2358
2359   if (gfc_match_char ('=') == MATCH_NO)
2360     {
2361       gfc_error ("Expected = sign in PARAMETER statement at %C");
2362       return MATCH_ERROR;
2363     }
2364
2365   m = gfc_match_init_expr (&init);
2366   if (m == MATCH_NO)
2367     gfc_error ("Expected expression at %C in PARAMETER statement");
2368   if (m != MATCH_YES)
2369     return m;
2370
2371   if (sym->ts.type == BT_UNKNOWN
2372       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2373     {
2374       m = MATCH_ERROR;
2375       goto cleanup;
2376     }
2377
2378   if (gfc_check_assign_symbol (sym, init) == FAILURE
2379       || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
2380     {
2381       m = MATCH_ERROR;
2382       goto cleanup;
2383     }
2384
2385   sym->value = init;
2386   return MATCH_YES;
2387
2388 cleanup:
2389   gfc_free_expr (init);
2390   return m;
2391 }
2392
2393
2394 /* Match a parameter statement, with the weird syntax that these have.  */
2395
2396 match
2397 gfc_match_parameter (void)
2398 {
2399   match m;
2400
2401   if (gfc_match_char ('(') == MATCH_NO)
2402     return MATCH_NO;
2403
2404   for (;;)
2405     {
2406       m = do_parm ();
2407       if (m != MATCH_YES)
2408         break;
2409
2410       if (gfc_match (" )%t") == MATCH_YES)
2411         break;
2412
2413       if (gfc_match_char (',') != MATCH_YES)
2414         {
2415           gfc_error ("Unexpected characters in PARAMETER statement at %C");
2416           m = MATCH_ERROR;
2417           break;
2418         }
2419     }
2420
2421   return m;
2422 }
2423
2424
2425 /* Save statements have a special syntax.  */
2426
2427 match
2428 gfc_match_save (void)
2429 {
2430   char n[GFC_MAX_SYMBOL_LEN+1];
2431   gfc_common_head *c;
2432   gfc_symbol *sym;
2433   match m;
2434
2435   if (gfc_match_eos () == MATCH_YES)
2436     {
2437       if (gfc_current_ns->seen_save)
2438         {
2439           gfc_error ("Blanket SAVE statement at %C follows previous "
2440                      "SAVE statement");
2441
2442           return MATCH_ERROR;
2443         }
2444
2445       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
2446       return MATCH_YES;
2447     }
2448
2449   if (gfc_current_ns->save_all)
2450     {
2451       gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2452       return MATCH_ERROR;
2453     }
2454
2455   gfc_match (" ::");
2456
2457   for (;;)
2458     {
2459       m = gfc_match_symbol (&sym, 0);
2460       switch (m)
2461         {
2462         case MATCH_YES:
2463           if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
2464             return MATCH_ERROR;
2465           goto next_item;
2466
2467         case MATCH_NO:
2468           break;
2469
2470         case MATCH_ERROR:
2471           return MATCH_ERROR;
2472         }
2473
2474       m = gfc_match (" / %n /", &n);
2475       if (m == MATCH_ERROR)
2476         return MATCH_ERROR;
2477       if (m == MATCH_NO)
2478         goto syntax;
2479
2480       c = gfc_get_common (n);
2481
2482       if (c->use_assoc)
2483         {
2484           gfc_error("COMMON block '%s' at %C is already USE associated", n);
2485           return MATCH_ERROR;
2486         }
2487
2488       c->saved = 1;
2489
2490       gfc_current_ns->seen_save = 1;
2491
2492     next_item:
2493       if (gfc_match_eos () == MATCH_YES)
2494         break;
2495       if (gfc_match_char (',') != MATCH_YES)
2496         goto syntax;
2497     }
2498
2499   return MATCH_YES;
2500
2501 syntax:
2502   gfc_error ("Syntax error in SAVE statement at %C");
2503   return MATCH_ERROR;
2504 }
2505
2506
2507 /* Match a module procedure statement.  Note that we have to modify
2508    symbols in the parent's namespace because the current one was there
2509    to receive symbols that are in a interface's formal argument list.  */
2510
2511 match
2512 gfc_match_modproc (void)
2513 {
2514   char name[GFC_MAX_SYMBOL_LEN + 1];
2515   gfc_symbol *sym;
2516   match m;
2517
2518   if (gfc_state_stack->state != COMP_INTERFACE
2519       || gfc_state_stack->previous == NULL
2520       || current_interface.type == INTERFACE_NAMELESS)
2521     {
2522       gfc_error
2523         ("MODULE PROCEDURE at %C must be in a generic module interface");
2524       return MATCH_ERROR;
2525     }
2526
2527   for (;;)
2528     {
2529       m = gfc_match_name (name);
2530       if (m == MATCH_NO)
2531         goto syntax;
2532       if (m != MATCH_YES)
2533         return MATCH_ERROR;
2534
2535       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
2536         return MATCH_ERROR;
2537
2538       if (sym->attr.proc != PROC_MODULE
2539           && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
2540         return MATCH_ERROR;
2541
2542       if (gfc_add_interface (sym) == FAILURE)
2543         return MATCH_ERROR;
2544
2545       if (gfc_match_eos () == MATCH_YES)
2546         break;
2547       if (gfc_match_char (',') != MATCH_YES)
2548         goto syntax;
2549     }
2550
2551   return MATCH_YES;
2552
2553 syntax:
2554   gfc_syntax_error (ST_MODULE_PROC);
2555   return MATCH_ERROR;
2556 }
2557
2558
2559 /* Match the beginning of a derived type declaration.  If a type name
2560    was the result of a function, then it is possible to have a symbol
2561    already to be known as a derived type yet have no components.  */
2562
2563 match
2564 gfc_match_derived_decl (void)
2565 {
2566   char name[GFC_MAX_SYMBOL_LEN + 1];
2567   symbol_attribute attr;
2568   gfc_symbol *sym;
2569   match m;
2570
2571   if (gfc_current_state () == COMP_DERIVED)
2572     return MATCH_NO;
2573
2574   gfc_clear_attr (&attr);
2575
2576 loop:
2577   if (gfc_match (" , private") == MATCH_YES)
2578     {
2579       if (gfc_find_state (COMP_MODULE) == FAILURE)
2580         {
2581           gfc_error
2582             ("Derived type at %C can only be PRIVATE within a MODULE");
2583           return MATCH_ERROR;
2584         }
2585
2586       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
2587         return MATCH_ERROR;
2588       goto loop;
2589     }
2590
2591   if (gfc_match (" , public") == MATCH_YES)
2592     {
2593       if (gfc_find_state (COMP_MODULE) == FAILURE)
2594         {
2595           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2596           return MATCH_ERROR;
2597         }
2598
2599       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
2600         return MATCH_ERROR;
2601       goto loop;
2602     }
2603
2604   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
2605     {
2606       gfc_error ("Expected :: in TYPE definition at %C");
2607       return MATCH_ERROR;
2608     }
2609
2610   m = gfc_match (" %n%t", name);
2611   if (m != MATCH_YES)
2612     return m;
2613
2614   /* Make sure the name isn't the name of an intrinsic type.  The
2615      'double precision' type doesn't get past the name matcher.  */
2616   if (strcmp (name, "integer") == 0
2617       || strcmp (name, "real") == 0
2618       || strcmp (name, "character") == 0
2619       || strcmp (name, "logical") == 0
2620       || strcmp (name, "complex") == 0)
2621     {
2622       gfc_error
2623         ("Type name '%s' at %C cannot be the same as an intrinsic type",
2624          name);
2625       return MATCH_ERROR;
2626     }
2627
2628   if (gfc_get_symbol (name, NULL, &sym))
2629     return MATCH_ERROR;
2630
2631   if (sym->ts.type != BT_UNKNOWN)
2632     {
2633       gfc_error ("Derived type name '%s' at %C already has a basic type "
2634                  "of %s", sym->name, gfc_typename (&sym->ts));
2635       return MATCH_ERROR;
2636     }
2637
2638   /* The symbol may already have the derived attribute without the
2639      components.  The ways this can happen is via a function
2640      definition, an INTRINSIC statement or a subtype in another
2641      derived type that is a pointer.  The first part of the AND clause
2642      is true if a the symbol is not the return value of a function. */
2643   if (sym->attr.flavor != FL_DERIVED
2644       && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
2645     return MATCH_ERROR;
2646
2647   if (sym->components != NULL)
2648     {
2649       gfc_error
2650         ("Derived type definition of '%s' at %C has already been defined",
2651          sym->name);
2652       return MATCH_ERROR;
2653     }
2654
2655   if (attr.access != ACCESS_UNKNOWN
2656       && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
2657     return MATCH_ERROR;
2658
2659   gfc_new_block = sym;
2660
2661   return MATCH_YES;
2662 }