gcc/fortran/decl.c

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