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 *function, *result, *entry;
1875   char name[GFC_MAX_SYMBOL_LEN + 1];
1876   gfc_compile_state state;
1877   match m;
1878
1879   m = gfc_match_name (name);
1880   if (m != MATCH_YES)
1881     return m;
1882
1883   if (get_proc_name (name, &entry))
1884     return MATCH_ERROR;
1885
1886   gfc_enclosing_unit (&state);
1887   switch (state)
1888     {
1889     case COMP_SUBROUTINE:
1890       m = gfc_match_formal_arglist (entry, 0, 1);
1891       if (m != MATCH_YES)
1892         return MATCH_ERROR;
1893
1894       if (gfc_current_state () != COMP_SUBROUTINE)
1895         goto exec_construct;
1896
1897       if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1898           || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
1899         return MATCH_ERROR;
1900
1901       break;
1902
1903     case COMP_FUNCTION:
1904       m = gfc_match_formal_arglist (entry, 0, 0);
1905       if (m != MATCH_YES)
1906         return MATCH_ERROR;
1907
1908       if (gfc_current_state () != COMP_FUNCTION)
1909         goto exec_construct;
1910       function = gfc_state_stack->sym;
1911
1912       result = NULL;
1913
1914       if (gfc_match_eos () == MATCH_YES)
1915         {
1916           if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1917               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1918             return MATCH_ERROR;
1919
1920           entry->result = function->result;
1921
1922         }
1923       else
1924         {
1925           m = match_result (function, &result);
1926           if (m == MATCH_NO)
1927             gfc_syntax_error (ST_ENTRY);
1928           if (m != MATCH_YES)
1929             return MATCH_ERROR;
1930
1931           if (gfc_add_result (&result->attr, NULL) == FAILURE
1932               || gfc_add_entry (&entry->attr, NULL) == FAILURE
1933               || gfc_add_function (&entry->attr, NULL) == FAILURE)
1934             return MATCH_ERROR;
1935         }
1936
1937       if (function->attr.recursive && result == NULL)
1938         {
1939           gfc_error ("RESULT attribute required in ENTRY statement at %C");
1940           return MATCH_ERROR;
1941         }
1942
1943       break;
1944
1945     default:
1946       goto exec_construct;
1947     }
1948
1949   if (gfc_match_eos () != MATCH_YES)
1950     {
1951       gfc_syntax_error (ST_ENTRY);
1952       return MATCH_ERROR;
1953     }
1954
1955   return MATCH_YES;
1956
1957 exec_construct:
1958   gfc_error ("ENTRY statement at %C cannot appear within %s",
1959              gfc_state_name (gfc_current_state ()));
1960
1961   return MATCH_ERROR;
1962 }
1963
1964
1965 /* Match a subroutine statement, including optional prefixes.  */
1966
1967 match
1968 gfc_match_subroutine (void)
1969 {
1970   char name[GFC_MAX_SYMBOL_LEN + 1];
1971   gfc_symbol *sym;
1972   match m;
1973
1974   if (gfc_current_state () != COMP_NONE
1975       && gfc_current_state () != COMP_INTERFACE
1976       && gfc_current_state () != COMP_CONTAINS)
1977     return MATCH_NO;
1978
1979   m = match_prefix (NULL);
1980   if (m != MATCH_YES)
1981     return m;
1982
1983   m = gfc_match ("subroutine% %n", name);
1984   if (m != MATCH_YES)
1985     return m;
1986
1987   if (get_proc_name (name, &sym))
1988     return MATCH_ERROR;
1989   gfc_new_block = sym;
1990
1991   if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1992     return MATCH_ERROR;
1993
1994   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
1995     return MATCH_ERROR;
1996
1997   if (gfc_match_eos () != MATCH_YES)
1998     {
1999       gfc_syntax_error (ST_SUBROUTINE);
2000       return MATCH_ERROR;
2001     }
2002
2003   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2004     return MATCH_ERROR;
2005
2006   return MATCH_YES;
2007 }
2008
2009
2010 /* Return nonzero if we're currenly compiling a contained procedure.  */
2011
2012 static int
2013 contained_procedure (void)
2014 {
2015   gfc_state_data *s;
2016
2017   for (s=gfc_state_stack; s; s=s->previous)
2018     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2019        && s->previous != NULL
2020        && s->previous->state == COMP_CONTAINS)
2021       return 1;
2022
2023   return 0;
2024 }
2025
2026 /* Match any of the various end-block statements.  Returns the type of
2027    END to the caller.  The END INTERFACE, END IF, END DO and END
2028    SELECT statements cannot be replaced by a single END statement.  */
2029
2030 match
2031 gfc_match_end (gfc_statement * st)
2032 {
2033   char name[GFC_MAX_SYMBOL_LEN + 1];
2034   gfc_compile_state state;
2035   locus old_loc;
2036   const char *block_name;
2037   const char *target;
2038   int eos_ok;
2039   match m;
2040
2041   old_loc = gfc_current_locus;
2042   if (gfc_match ("end") != MATCH_YES)
2043     return MATCH_NO;
2044
2045   state = gfc_current_state ();
2046   block_name =
2047     gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2048
2049   if (state == COMP_CONTAINS)
2050     {
2051       state = gfc_state_stack->previous->state;
2052       block_name = gfc_state_stack->previous->sym == NULL ? NULL
2053         : gfc_state_stack->previous->sym->name;
2054     }
2055
2056   switch (state)
2057     {
2058     case COMP_NONE:
2059     case COMP_PROGRAM:
2060       *st = ST_END_PROGRAM;
2061       target = " program";
2062       eos_ok = 1;
2063       break;
2064
2065     case COMP_SUBROUTINE:
2066       *st = ST_END_SUBROUTINE;
2067       target = " subroutine";
2068       eos_ok = !contained_procedure ();
2069       break;
2070
2071     case COMP_FUNCTION:
2072       *st = ST_END_FUNCTION;
2073       target = " function";
2074       eos_ok = !contained_procedure ();
2075       break;
2076
2077     case COMP_BLOCK_DATA:
2078       *st = ST_END_BLOCK_DATA;
2079       target = " block data";
2080       eos_ok = 1;
2081       break;
2082
2083     case COMP_MODULE:
2084       *st = ST_END_MODULE;
2085       target = " module";
2086       eos_ok = 1;
2087       break;
2088
2089     case COMP_INTERFACE:
2090       *st = ST_END_INTERFACE;
2091       target = " interface";
2092       eos_ok = 0;
2093       break;
2094
2095     case COMP_DERIVED:
2096       *st = ST_END_TYPE;
2097       target = " type";
2098       eos_ok = 0;
2099       break;
2100
2101     case COMP_IF:
2102       *st = ST_ENDIF;
2103       target = " if";
2104       eos_ok = 0;
2105       break;
2106
2107     case COMP_DO:
2108       *st = ST_ENDDO;
2109       target = " do";
2110       eos_ok = 0;
2111       break;
2112
2113     case COMP_SELECT:
2114       *st = ST_END_SELECT;
2115       target = " select";
2116       eos_ok = 0;
2117       break;
2118
2119     case COMP_FORALL:
2120       *st = ST_END_FORALL;
2121       target = " forall";
2122       eos_ok = 0;
2123       break;
2124
2125     case COMP_WHERE:
2126       *st = ST_END_WHERE;
2127       target = " where";
2128       eos_ok = 0;
2129       break;
2130
2131     default:
2132       gfc_error ("Unexpected END statement at %C");
2133       goto cleanup;
2134     }
2135
2136   if (gfc_match_eos () == MATCH_YES)
2137     {
2138       if (!eos_ok)
2139         {
2140           /* We would have required END [something]  */
2141           gfc_error ("%s statement expected at %C",
2142                      gfc_ascii_statement (*st));
2143           goto cleanup;
2144         }
2145
2146       return MATCH_YES;
2147     }
2148
2149   /* Verify that we've got the sort of end-block that we're expecting.  */
2150   if (gfc_match (target) != MATCH_YES)
2151     {
2152       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
2153       goto cleanup;
2154     }
2155
2156   /* If we're at the end, make sure a block name wasn't required.  */
2157   if (gfc_match_eos () == MATCH_YES)
2158     {
2159
2160       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
2161         return MATCH_YES;
2162
2163       if (gfc_current_block () == NULL)
2164         return MATCH_YES;
2165
2166       gfc_error ("Expected block name of '%s' in %s statement at %C",
2167                  block_name, gfc_ascii_statement (*st));
2168
2169       return MATCH_ERROR;
2170     }
2171
2172   /* END INTERFACE has a special handler for its several possible endings.  */
2173   if (*st == ST_END_INTERFACE)
2174     return gfc_match_end_interface ();
2175
2176   /* We haven't hit the end of statement, so what is left must be an end-name.  */
2177   m = gfc_match_space ();
2178   if (m == MATCH_YES)
2179     m = gfc_match_name (name);
2180
2181   if (m == MATCH_NO)
2182     gfc_error ("Expected terminating name at %C");
2183   if (m != MATCH_YES)
2184     goto cleanup;
2185
2186   if (block_name == NULL)
2187     goto syntax;
2188
2189   if (strcmp (name, block_name) != 0)
2190     {
2191       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
2192                  gfc_ascii_statement (*st));
2193       goto cleanup;
2194     }
2195
2196   if (gfc_match_eos () == MATCH_YES)
2197     return MATCH_YES;
2198
2199 syntax:
2200   gfc_syntax_error (*st);
2201
2202 cleanup:
2203   gfc_current_locus = old_loc;
2204   return MATCH_ERROR;
2205 }
2206
2207
2208
2209 /***************** Attribute declaration statements ****************/
2210
2211 /* Set the attribute of a single variable.  */
2212
2213 static match
2214 attr_decl1 (void)
2215 {
2216   char name[GFC_MAX_SYMBOL_LEN + 1];
2217   gfc_array_spec *as;
2218   gfc_symbol *sym;
2219   locus var_locus;
2220   match m;
2221
2222   as = NULL;
2223
2224   m = gfc_match_name (name);
2225   if (m != MATCH_YES)
2226     goto cleanup;
2227
2228   if (find_special (name, &sym))
2229     return MATCH_ERROR;
2230
2231   var_locus = gfc_current_locus;
2232
2233   /* Deal with possible array specification for certain attributes.  */
2234   if (current_attr.dimension
2235       || current_attr.allocatable
2236       || current_attr.pointer
2237       || current_attr.target)
2238     {
2239       m = gfc_match_array_spec (&as);
2240       if (m == MATCH_ERROR)
2241         goto cleanup;
2242
2243       if (current_attr.dimension && m == MATCH_NO)
2244         {
2245           gfc_error
2246             ("Missing array specification at %L in DIMENSION statement",
2247              &var_locus);
2248           m = MATCH_ERROR;
2249           goto cleanup;
2250         }
2251
2252       if ((current_attr.allocatable || current_attr.pointer)
2253           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2254         {
2255           gfc_error ("Array specification must be deferred at %L",
2256                      &var_locus);
2257           m = MATCH_ERROR;
2258           goto cleanup;
2259         }
2260     }
2261
2262   /* Update symbol table.  DIMENSION attribute is set in gfc_set_array_spec().  */
2263   if (current_attr.dimension == 0
2264       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2265     {
2266       m = MATCH_ERROR;
2267       goto cleanup;
2268     }
2269
2270   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2271     {
2272       m = MATCH_ERROR;
2273       goto cleanup;
2274     }
2275
2276   if ((current_attr.external || current_attr.intrinsic)
2277       && sym->attr.flavor != FL_PROCEDURE
2278       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
2279     {
2280       m = MATCH_ERROR;
2281       goto cleanup;
2282     }
2283
2284   return MATCH_YES;
2285
2286 cleanup:
2287   gfc_free_array_spec (as);
2288   return m;
2289 }
2290
2291
2292 /* Generic attribute declaration subroutine.  Used for attributes that
2293    just have a list of names.  */
2294
2295 static match
2296 attr_decl (void)
2297 {
2298   match m;
2299
2300   /* Gobble the optional double colon, by simply ignoring the result
2301      of gfc_match().  */
2302   gfc_match (" ::");
2303
2304   for (;;)
2305     {
2306       m = attr_decl1 ();
2307       if (m != MATCH_YES)
2308         break;
2309
2310       if (gfc_match_eos () == MATCH_YES)
2311         {
2312           m = MATCH_YES;
2313           break;
2314         }
2315
2316       if (gfc_match_char (',') != MATCH_YES)
2317         {
2318           gfc_error ("Unexpected character in variable list at %C");
2319           m = MATCH_ERROR;
2320           break;
2321         }
2322     }
2323
2324   return m;
2325 }
2326
2327
2328 match
2329 gfc_match_external (void)
2330 {
2331
2332   gfc_clear_attr (&current_attr);
2333   gfc_add_external (&current_attr, NULL);
2334
2335   return attr_decl ();
2336 }
2337
2338
2339
2340 match
2341 gfc_match_intent (void)
2342 {
2343   sym_intent intent;
2344
2345   intent = match_intent_spec ();
2346   if (intent == INTENT_UNKNOWN)
2347     return MATCH_ERROR;
2348
2349   gfc_clear_attr (&current_attr);
2350   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2351
2352   return attr_decl ();
2353 }
2354
2355
2356 match
2357 gfc_match_intrinsic (void)
2358 {
2359
2360   gfc_clear_attr (&current_attr);
2361   gfc_add_intrinsic (&current_attr, NULL);
2362
2363   return attr_decl ();
2364 }
2365
2366
2367 match
2368 gfc_match_optional (void)
2369 {
2370
2371   gfc_clear_attr (&current_attr);
2372   gfc_add_optional (&current_attr, NULL);
2373
2374   return attr_decl ();
2375 }
2376
2377
2378 match
2379 gfc_match_pointer (void)
2380 {
2381
2382   gfc_clear_attr (&current_attr);
2383   gfc_add_pointer (&current_attr, NULL);
2384
2385   return attr_decl ();
2386 }
2387
2388
2389 match
2390 gfc_match_allocatable (void)
2391 {
2392
2393   gfc_clear_attr (&current_attr);
2394   gfc_add_allocatable (&current_attr, NULL);
2395
2396   return attr_decl ();
2397 }
2398
2399
2400 match
2401 gfc_match_dimension (void)
2402 {
2403
2404   gfc_clear_attr (&current_attr);
2405   gfc_add_dimension (&current_attr, NULL);
2406
2407   return attr_decl ();
2408 }
2409
2410
2411 match
2412 gfc_match_target (void)
2413 {
2414
2415   gfc_clear_attr (&current_attr);
2416   gfc_add_target (&current_attr, NULL);
2417
2418   return attr_decl ();
2419 }
2420
2421
2422 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2423    statement.  */
2424
2425 static match
2426 access_attr_decl (gfc_statement st)
2427 {
2428   char name[GFC_MAX_SYMBOL_LEN + 1];
2429   interface_type type;
2430   gfc_user_op *uop;
2431   gfc_symbol *sym;
2432   gfc_intrinsic_op operator;
2433   match m;
2434
2435   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2436     goto done;
2437
2438   for (;;)
2439     {
2440       m = gfc_match_generic_spec (&type, name, &operator);
2441       if (m == MATCH_NO)
2442         goto syntax;
2443       if (m == MATCH_ERROR)
2444         return MATCH_ERROR;
2445
2446       switch (type)
2447         {
2448         case INTERFACE_NAMELESS:
2449           goto syntax;
2450
2451         case INTERFACE_GENERIC:
2452           if (gfc_get_symbol (name, NULL, &sym))
2453             goto done;
2454
2455           if (gfc_add_access (&sym->attr,
2456                               (st ==
2457                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2458                               NULL) == FAILURE)
2459             return MATCH_ERROR;
2460
2461           break;
2462
2463         case INTERFACE_INTRINSIC_OP:
2464           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2465             {
2466               gfc_current_ns->operator_access[operator] =
2467                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2468             }
2469           else
2470             {
2471               gfc_error ("Access specification of the %s operator at %C has "
2472                          "already been specified", gfc_op2string (operator));
2473               goto done;
2474             }
2475
2476           break;
2477
2478         case INTERFACE_USER_OP:
2479           uop = gfc_get_uop (name);
2480
2481           if (uop->access == ACCESS_UNKNOWN)
2482             {
2483               uop->access =
2484                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2485             }
2486           else
2487             {
2488               gfc_error
2489                 ("Access specification of the .%s. operator at %C has "
2490                  "already been specified", sym->name);
2491               goto done;
2492             }
2493
2494           break;
2495         }
2496
2497       if (gfc_match_char (',') == MATCH_NO)
2498         break;
2499     }
2500
2501   if (gfc_match_eos () != MATCH_YES)
2502     goto syntax;
2503   return MATCH_YES;
2504
2505 syntax:
2506   gfc_syntax_error (st);
2507
2508 done:
2509   return MATCH_ERROR;
2510 }
2511
2512
2513 /* The PRIVATE statement is a bit weird in that it can be a attribute
2514    declaration, but also works as a standlone statement inside of a
2515    type declaration or a module.  */
2516
2517 match
2518 gfc_match_private (gfc_statement * st)
2519 {
2520
2521   if (gfc_match ("private") != MATCH_YES)
2522     return MATCH_NO;
2523
2524   if (gfc_current_state () == COMP_DERIVED)
2525     {
2526       if (gfc_match_eos () == MATCH_YES)
2527         {
2528           *st = ST_PRIVATE;
2529           return MATCH_YES;
2530         }
2531
2532       gfc_syntax_error (ST_PRIVATE);
2533       return MATCH_ERROR;
2534     }
2535
2536   if (gfc_match_eos () == MATCH_YES)
2537     {
2538       *st = ST_PRIVATE;
2539       return MATCH_YES;
2540     }
2541
2542   *st = ST_ATTR_DECL;
2543   return access_attr_decl (ST_PRIVATE);
2544 }
2545
2546
2547 match
2548 gfc_match_public (gfc_statement * st)
2549 {
2550
2551   if (gfc_match ("public") != MATCH_YES)
2552     return MATCH_NO;
2553
2554   if (gfc_match_eos () == MATCH_YES)
2555     {
2556       *st = ST_PUBLIC;
2557       return MATCH_YES;
2558     }
2559
2560   *st = ST_ATTR_DECL;
2561   return access_attr_decl (ST_PUBLIC);
2562 }
2563
2564
2565 /* Workhorse for gfc_match_parameter.  */
2566
2567 static match
2568 do_parm (void)
2569 {
2570   gfc_symbol *sym;
2571   gfc_expr *init;
2572   match m;
2573
2574   m = gfc_match_symbol (&sym, 0);
2575   if (m == MATCH_NO)
2576     gfc_error ("Expected variable name at %C in PARAMETER statement");
2577
2578   if (m != MATCH_YES)
2579     return m;
2580
2581   if (gfc_match_char ('=') == MATCH_NO)
2582     {
2583       gfc_error ("Expected = sign in PARAMETER statement at %C");
2584       return MATCH_ERROR;
2585     }
2586
2587   m = gfc_match_init_expr (&init);
2588   if (m == MATCH_NO)
2589     gfc_error ("Expected expression at %C in PARAMETER statement");
2590   if (m != MATCH_YES)
2591     return m;
2592
2593   if (sym->ts.type == BT_UNKNOWN
2594       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2595     {
2596       m = MATCH_ERROR;
2597       goto cleanup;
2598     }
2599
2600   if (gfc_check_assign_symbol (sym, init) == FAILURE
2601       || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
2602     {
2603       m = MATCH_ERROR;
2604       goto cleanup;
2605     }
2606
2607   sym->value = init;
2608   return MATCH_YES;
2609
2610 cleanup:
2611   gfc_free_expr (init);
2612   return m;
2613 }
2614
2615
2616 /* Match a parameter statement, with the weird syntax that these have.  */
2617
2618 match
2619 gfc_match_parameter (void)
2620 {
2621   match m;
2622
2623   if (gfc_match_char ('(') == MATCH_NO)
2624     return MATCH_NO;
2625
2626   for (;;)
2627     {
2628       m = do_parm ();
2629       if (m != MATCH_YES)
2630         break;
2631
2632       if (gfc_match (" )%t") == MATCH_YES)
2633         break;
2634
2635       if (gfc_match_char (',') != MATCH_YES)
2636         {
2637           gfc_error ("Unexpected characters in PARAMETER statement at %C");
2638           m = MATCH_ERROR;
2639           break;
2640         }
2641     }
2642
2643   return m;
2644 }
2645
2646
2647 /* Save statements have a special syntax.  */
2648
2649 match
2650 gfc_match_save (void)
2651 {
2652   char n[GFC_MAX_SYMBOL_LEN+1];
2653   gfc_common_head *c;
2654   gfc_symbol *sym;
2655   match m;
2656
2657   if (gfc_match_eos () == MATCH_YES)
2658     {
2659       if (gfc_current_ns->seen_save)
2660         {
2661           gfc_error ("Blanket SAVE statement at %C follows previous "
2662                      "SAVE statement");
2663
2664           return MATCH_ERROR;
2665         }
2666
2667       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
2668       return MATCH_YES;
2669     }
2670
2671   if (gfc_current_ns->save_all)
2672     {
2673       gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2674       return MATCH_ERROR;
2675     }
2676
2677   gfc_match (" ::");
2678
2679   for (;;)
2680     {
2681       m = gfc_match_symbol (&sym, 0);
2682       switch (m)
2683         {
2684         case MATCH_YES:
2685           if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
2686             return MATCH_ERROR;
2687           goto next_item;
2688
2689         case MATCH_NO:
2690           break;
2691
2692         case MATCH_ERROR:
2693           return MATCH_ERROR;
2694         }
2695
2696       m = gfc_match (" / %n /", &n);
2697       if (m == MATCH_ERROR)
2698         return MATCH_ERROR;
2699       if (m == MATCH_NO)
2700         goto syntax;
2701
2702       c = gfc_get_common (n);
2703
2704       if (c->use_assoc)
2705         {
2706           gfc_error("COMMON block '%s' at %C is already USE associated", n);
2707           return MATCH_ERROR;
2708         }
2709
2710       c->saved = 1;
2711
2712       gfc_current_ns->seen_save = 1;
2713
2714     next_item:
2715       if (gfc_match_eos () == MATCH_YES)
2716         break;
2717       if (gfc_match_char (',') != MATCH_YES)
2718         goto syntax;
2719     }
2720
2721   return MATCH_YES;
2722
2723 syntax:
2724   gfc_error ("Syntax error in SAVE statement at %C");
2725   return MATCH_ERROR;
2726 }
2727
2728
2729 /* Match a module procedure statement.  Note that we have to modify
2730    symbols in the parent's namespace because the current one was there
2731    to receive symbols that are in a interface's formal argument list.  */
2732
2733 match
2734 gfc_match_modproc (void)
2735 {
2736   char name[GFC_MAX_SYMBOL_LEN + 1];
2737   gfc_symbol *sym;
2738   match m;
2739
2740   if (gfc_state_stack->state != COMP_INTERFACE
2741       || gfc_state_stack->previous == NULL
2742       || current_interface.type == INTERFACE_NAMELESS)
2743     {
2744       gfc_error
2745         ("MODULE PROCEDURE at %C must be in a generic module interface");
2746       return MATCH_ERROR;
2747     }
2748
2749   for (;;)
2750     {
2751       m = gfc_match_name (name);
2752       if (m == MATCH_NO)
2753         goto syntax;
2754       if (m != MATCH_YES)
2755         return MATCH_ERROR;
2756
2757       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
2758         return MATCH_ERROR;
2759
2760       if (sym->attr.proc != PROC_MODULE
2761           && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
2762         return MATCH_ERROR;
2763
2764       if (gfc_add_interface (sym) == FAILURE)
2765         return MATCH_ERROR;
2766
2767       if (gfc_match_eos () == MATCH_YES)
2768         break;
2769       if (gfc_match_char (',') != MATCH_YES)
2770         goto syntax;
2771     }
2772
2773   return MATCH_YES;
2774
2775 syntax:
2776   gfc_syntax_error (ST_MODULE_PROC);
2777   return MATCH_ERROR;
2778 }
2779
2780
2781 /* Match the beginning of a derived type declaration.  If a type name
2782    was the result of a function, then it is possible to have a symbol
2783    already to be known as a derived type yet have no components.  */
2784
2785 match
2786 gfc_match_derived_decl (void)
2787 {
2788   char name[GFC_MAX_SYMBOL_LEN + 1];
2789   symbol_attribute attr;
2790   gfc_symbol *sym;
2791   match m;
2792
2793   if (gfc_current_state () == COMP_DERIVED)
2794     return MATCH_NO;
2795
2796   gfc_clear_attr (&attr);
2797
2798 loop:
2799   if (gfc_match (" , private") == MATCH_YES)
2800     {
2801       if (gfc_find_state (COMP_MODULE) == FAILURE)
2802         {
2803           gfc_error
2804             ("Derived type at %C can only be PRIVATE within a MODULE");
2805           return MATCH_ERROR;
2806         }
2807
2808       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
2809         return MATCH_ERROR;
2810       goto loop;
2811     }
2812
2813   if (gfc_match (" , public") == MATCH_YES)
2814     {
2815       if (gfc_find_state (COMP_MODULE) == FAILURE)
2816         {
2817           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2818           return MATCH_ERROR;
2819         }
2820
2821       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
2822         return MATCH_ERROR;
2823       goto loop;
2824     }
2825
2826   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
2827     {
2828       gfc_error ("Expected :: in TYPE definition at %C");
2829       return MATCH_ERROR;
2830     }
2831
2832   m = gfc_match (" %n%t", name);
2833   if (m != MATCH_YES)
2834     return m;
2835
2836   /* Make sure the name isn't the name of an intrinsic type.  The
2837      'double precision' type doesn't get past the name matcher.  */
2838   if (strcmp (name, "integer") == 0
2839       || strcmp (name, "real") == 0
2840       || strcmp (name, "character") == 0
2841       || strcmp (name, "logical") == 0
2842       || strcmp (name, "complex") == 0)
2843     {
2844       gfc_error
2845         ("Type name '%s' at %C cannot be the same as an intrinsic type",
2846          name);
2847       return MATCH_ERROR;
2848     }
2849
2850   if (gfc_get_symbol (name, NULL, &sym))
2851     return MATCH_ERROR;
2852
2853   if (sym->ts.type != BT_UNKNOWN)
2854     {
2855       gfc_error ("Derived type name '%s' at %C already has a basic type "
2856                  "of %s", sym->name, gfc_typename (&sym->ts));
2857       return MATCH_ERROR;
2858     }
2859
2860   /* The symbol may already have the derived attribute without the
2861      components.  The ways this can happen is via a function
2862      definition, an INTRINSIC statement or a subtype in another
2863      derived type that is a pointer.  The first part of the AND clause
2864      is true if a the symbol is not the return value of a function. */
2865   if (sym->attr.flavor != FL_DERIVED
2866       && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
2867     return MATCH_ERROR;
2868
2869   if (sym->components != NULL)
2870     {
2871       gfc_error
2872         ("Derived type definition of '%s' at %C has already been defined",
2873          sym->name);
2874       return MATCH_ERROR;
2875     }
2876
2877   if (attr.access != ACCESS_UNKNOWN
2878       && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
2879     return MATCH_ERROR;
2880
2881   gfc_new_block = sym;
2882
2883   return MATCH_YES;
2884 }