gcc/fortran/decl.c

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