gcc/fortran/interface.c

   1 /* Deal with interfaces.
   2    Copyright (C) 2000-2013 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 3, 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 COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 /* Deal with interfaces.  An explicit interface is represented as a
  23    singly linked list of formal argument structures attached to the
  24    relevant symbols.  For an implicit interface, the arguments don't
  25    point to symbols.  Explicit interfaces point to namespaces that
  26    contain the symbols within that interface.
  27
  28    Implicit interfaces are linked together in a singly linked list
  29    along the next_if member of symbol nodes.  Since a particular
  30    symbol can only have a single explicit interface, the symbol cannot
  31    be part of multiple lists and a single next-member suffices.
  32
  33    This is not the case for general classes, though.  An operator
  34    definition is independent of just about all other uses and has it's
  35    own head pointer.
  36
  37    Nameless interfaces:
  38      Nameless interfaces create symbols with explicit interfaces within
  39      the current namespace.  They are otherwise unlinked.
  40
  41    Generic interfaces:
  42      The generic name points to a linked list of symbols.  Each symbol
  43      has an explicit interface.  Each explicit interface has its own
  44      namespace containing the arguments.  Module procedures are symbols in
  45      which the interface is added later when the module procedure is parsed.
  46
  47    User operators:
  48      User-defined operators are stored in a their own set of symtrees
  49      separate from regular symbols.  The symtrees point to gfc_user_op
  50      structures which in turn head up a list of relevant interfaces.
  51
  52    Extended intrinsics and assignment:
  53      The head of these interface lists are stored in the containing namespace.
  54
  55    Implicit interfaces:
  56      An implicit interface is represented as a singly linked list of
  57      formal argument list structures that don't point to any symbol
  58      nodes -- they just contain types.
  59
  60
  61    When a subprogram is defined, the program unit's name points to an
  62    interface as usual, but the link to the namespace is NULL and the
  63    formal argument list points to symbols within the same namespace as
  64    the program unit name.  */
  65
  66 #include "config.h"
  67 #include "system.h"
  68 #include "coretypes.h"
  69 #include "gfortran.h"
  70 #include "match.h"
  71 #include "arith.h"
  72
  73 /* The current_interface structure holds information about the
  74    interface currently being parsed.  This structure is saved and
  75    restored during recursive interfaces.  */
  76
  77 gfc_interface_info current_interface;
  78
  79
  80 /* Free a singly linked list of gfc_interface structures.  */
  81
  82 void
  83 gfc_free_interface (gfc_interface *intr)
  84 {
  85   gfc_interface *next;
  86
  87   for (; intr; intr = next)
  88     {
  89       next = intr->next;
  90       free (intr);
  91     }
  92 }
  93
  94
  95 /* Change the operators unary plus and minus into binary plus and
  96    minus respectively, leaving the rest unchanged.  */
  97
  98 static gfc_intrinsic_op
  99 fold_unary_intrinsic (gfc_intrinsic_op op)
 100 {
 101   switch (op)
 102     {
 103     case INTRINSIC_UPLUS:
 104       op = INTRINSIC_PLUS;
 105       break;
 106     case INTRINSIC_UMINUS:
 107       op = INTRINSIC_MINUS;
 108       break;
 109     default:
 110       break;
 111     }
 112
 113   return op;
 114 }
 115
 116
 117 /* Match a generic specification.  Depending on which type of
 118    interface is found, the 'name' or 'op' pointers may be set.
 119    This subroutine doesn't return MATCH_NO.  */
 120
 121 match
 122 gfc_match_generic_spec (interface_type *type,
 123                         char *name,
 124                         gfc_intrinsic_op *op)
 125 {
 126   char buffer[GFC_MAX_SYMBOL_LEN + 1];
 127   match m;
 128   gfc_intrinsic_op i;
 129
 130   if (gfc_match (" assignment ( = )") == MATCH_YES)
 131     {
 132       *type = INTERFACE_INTRINSIC_OP;
 133       *op = INTRINSIC_ASSIGN;
 134       return MATCH_YES;
 135     }
 136
 137   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
 138     {                           /* Operator i/f */
 139       *type = INTERFACE_INTRINSIC_OP;
 140       *op = fold_unary_intrinsic (i);
 141       return MATCH_YES;
 142     }
 143
 144   *op = INTRINSIC_NONE;
 145   if (gfc_match (" operator ( ") == MATCH_YES)
 146     {
 147       m = gfc_match_defined_op_name (buffer, 1);
 148       if (m == MATCH_NO)
 149         goto syntax;
 150       if (m != MATCH_YES)
 151         return MATCH_ERROR;
 152
 153       m = gfc_match_char (')');
 154       if (m == MATCH_NO)
 155         goto syntax;
 156       if (m != MATCH_YES)
 157         return MATCH_ERROR;
 158
 159       strcpy (name, buffer);
 160       *type = INTERFACE_USER_OP;
 161       return MATCH_YES;
 162     }
 163
 164   if (gfc_match_name (buffer) == MATCH_YES)
 165     {
 166       strcpy (name, buffer);
 167       *type = INTERFACE_GENERIC;
 168       return MATCH_YES;
 169     }
 170
 171   *type = INTERFACE_NAMELESS;
 172   return MATCH_YES;
 173
 174 syntax:
 175   gfc_error ("Syntax error in generic specification at %C");
 176   return MATCH_ERROR;
 177 }
 178
 179
 180 /* Match one of the five F95 forms of an interface statement.  The
 181    matcher for the abstract interface follows.  */
 182
 183 match
 184 gfc_match_interface (void)
 185 {
 186   char name[GFC_MAX_SYMBOL_LEN + 1];
 187   interface_type type;
 188   gfc_symbol *sym;
 189   gfc_intrinsic_op op;
 190   match m;
 191
 192   m = gfc_match_space ();
 193
 194   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
 195     return MATCH_ERROR;
 196
 197   /* If we're not looking at the end of the statement now, or if this
 198      is not a nameless interface but we did not see a space, punt.  */
 199   if (gfc_match_eos () != MATCH_YES
 200       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
 201     {
 202       gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
 203                  "at %C");
 204       return MATCH_ERROR;
 205     }
 206
 207   current_interface.type = type;
 208
 209   switch (type)
 210     {
 211     case INTERFACE_GENERIC:
 212       if (gfc_get_symbol (name, NULL, &sym))
 213         return MATCH_ERROR;
 214
 215       if (!sym->attr.generic
 216           && !gfc_add_generic (&sym->attr, sym->name, NULL))
 217         return MATCH_ERROR;
 218
 219       if (sym->attr.dummy)
 220         {
 221           gfc_error ("Dummy procedure '%s' at %C cannot have a "
 222                      "generic interface", sym->name);
 223           return MATCH_ERROR;
 224         }
 225
 226       current_interface.sym = gfc_new_block = sym;
 227       break;
 228
 229     case INTERFACE_USER_OP:
 230       current_interface.uop = gfc_get_uop (name);
 231       break;
 232
 233     case INTERFACE_INTRINSIC_OP:
 234       current_interface.op = op;
 235       break;
 236
 237     case INTERFACE_NAMELESS:
 238     case INTERFACE_ABSTRACT:
 239       break;
 240     }
 241
 242   return MATCH_YES;
 243 }
 244
 245
 246
 247 /* Match a F2003 abstract interface.  */
 248
 249 match
 250 gfc_match_abstract_interface (void)
 251 {
 252   match m;
 253
 254   if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
 255     return MATCH_ERROR;
 256
 257   m = gfc_match_eos ();
 258
 259   if (m != MATCH_YES)
 260     {
 261       gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
 262       return MATCH_ERROR;
 263     }
 264
 265   current_interface.type = INTERFACE_ABSTRACT;
 266
 267   return m;
 268 }
 269
 270
 271 /* Match the different sort of generic-specs that can be present after
 272    the END INTERFACE itself.  */
 273
 274 match
 275 gfc_match_end_interface (void)
 276 {
 277   char name[GFC_MAX_SYMBOL_LEN + 1];
 278   interface_type type;
 279   gfc_intrinsic_op op;
 280   match m;
 281
 282   m = gfc_match_space ();
 283
 284   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
 285     return MATCH_ERROR;
 286
 287   /* If we're not looking at the end of the statement now, or if this
 288      is not a nameless interface but we did not see a space, punt.  */
 289   if (gfc_match_eos () != MATCH_YES
 290       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
 291     {
 292       gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
 293                  "statement at %C");
 294       return MATCH_ERROR;
 295     }
 296
 297   m = MATCH_YES;
 298
 299   switch (current_interface.type)
 300     {
 301     case INTERFACE_NAMELESS:
 302     case INTERFACE_ABSTRACT:
 303       if (type != INTERFACE_NAMELESS)
 304         {
 305           gfc_error ("Expected a nameless interface at %C");
 306           m = MATCH_ERROR;
 307         }
 308
 309       break;
 310
 311     case INTERFACE_INTRINSIC_OP:
 312       if (type != current_interface.type || op != current_interface.op)
 313         {
 314
 315           if (current_interface.op == INTRINSIC_ASSIGN)
 316             {
 317               m = MATCH_ERROR;
 318               gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
 319             }
 320           else
 321             {
 322               const char *s1, *s2;
 323               s1 = gfc_op2string (current_interface.op);
 324               s2 = gfc_op2string (op);
 325
 326               /* The following if-statements are used to enforce C1202
 327                  from F2003.  */
 328               if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
 329                   || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
 330                 break;
 331               if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
 332                   || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
 333                 break;
 334               if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
 335                   || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
 336                 break;
 337               if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
 338                   || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
 339                 break;
 340               if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
 341                   || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
 342                 break;
 343               if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
 344                   || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
 345                 break;
 346
 347               m = MATCH_ERROR;
 348               gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
 349                          "but got %s", s1, s2);
 350             }
 351
 352         }
 353
 354       break;
 355
 356     case INTERFACE_USER_OP:
 357       /* Comparing the symbol node names is OK because only use-associated
 358          symbols can be renamed.  */
 359       if (type != current_interface.type
 360           || strcmp (current_interface.uop->name, name) != 0)
 361         {
 362           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
 363                      current_interface.uop->name);
 364           m = MATCH_ERROR;
 365         }
 366
 367       break;
 368
 369     case INTERFACE_GENERIC:
 370       if (type != current_interface.type
 371           || strcmp (current_interface.sym->name, name) != 0)
 372         {
 373           gfc_error ("Expecting 'END INTERFACE %s' at %C",
 374                      current_interface.sym->name);
 375           m = MATCH_ERROR;
 376         }
 377
 378       break;
 379     }
 380
 381   return m;
 382 }
 383
 384
 385 /* Compare two derived types using the criteria in 4.4.2 of the standard,
 386    recursing through gfc_compare_types for the components.  */
 387
 388 int
 389 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
 390 {
 391   gfc_component *dt1, *dt2;
 392
 393   if (derived1 == derived2)
 394     return 1;
 395
 396   gcc_assert (derived1 && derived2);
 397
 398   /* Special case for comparing derived types across namespaces.  If the
 399      true names and module names are the same and the module name is
 400      nonnull, then they are equal.  */
 401   if (strcmp (derived1->name, derived2->name) == 0
 402       && derived1->module != NULL && derived2->module != NULL
 403       && strcmp (derived1->module, derived2->module) == 0)
 404     return 1;
 405
 406   /* Compare type via the rules of the standard.  Both types must have
 407      the SEQUENCE or BIND(C) attribute to be equal.  */
 408
 409   if (strcmp (derived1->name, derived2->name))
 410     return 0;
 411
 412   if (derived1->component_access == ACCESS_PRIVATE
 413       || derived2->component_access == ACCESS_PRIVATE)
 414     return 0;
 415
 416   if (!(derived1->attr.sequence && derived2->attr.sequence)
 417       && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
 418     return 0;
 419
 420   dt1 = derived1->components;
 421   dt2 = derived2->components;
 422
 423   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
 424      simple test can speed things up.  Otherwise, lots of things have to
 425      match.  */
 426   for (;;)
 427     {
 428       if (strcmp (dt1->name, dt2->name) != 0)
 429         return 0;
 430
 431       if (dt1->attr.access != dt2->attr.access)
 432         return 0;
 433
 434       if (dt1->attr.pointer != dt2->attr.pointer)
 435         return 0;
 436
 437       if (dt1->attr.dimension != dt2->attr.dimension)
 438         return 0;
 439
 440      if (dt1->attr.allocatable != dt2->attr.allocatable)
 441         return 0;
 442
 443       if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
 444         return 0;
 445
 446       /* Make sure that link lists do not put this function into an
 447          endless recursive loop!  */
 448       if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 449             && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
 450             && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
 451         return 0;
 452
 453       else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 454                 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 455         return 0;
 456
 457       else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 458                 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 459         return 0;
 460
 461       dt1 = dt1->next;
 462       dt2 = dt2->next;
 463
 464       if (dt1 == NULL && dt2 == NULL)
 465         break;
 466       if (dt1 == NULL || dt2 == NULL)
 467         return 0;
 468     }
 469
 470   return 1;
 471 }
 472
 473
 474 /* Compare two typespecs, recursively if necessary.  */
 475
 476 int
 477 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
 478 {
 479   /* See if one of the typespecs is a BT_VOID, which is what is being used
 480      to allow the funcs like c_f_pointer to accept any pointer type.
 481      TODO: Possibly should narrow this to just the one typespec coming in
 482      that is for the formal arg, but oh well.  */
 483   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
 484     return 1;
 485
 486   if (ts1->type == BT_CLASS
 487       && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
 488     return 1;
 489
 490   /* F2003: C717  */
 491   if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
 492       && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
 493       && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
 494     return 1;
 495
 496   if (ts1->type != ts2->type
 497       && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
 498           || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
 499     return 0;
 500   if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
 501     return (ts1->kind == ts2->kind);
 502
 503   /* Compare derived types.  */
 504   if (gfc_type_compatible (ts1, ts2))
 505     return 1;
 506
 507   return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
 508 }
 509
 510
 511 static int
 512 compare_type (gfc_symbol *s1, gfc_symbol *s2)
 513 {
 514   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
 515     return 1;
 516
 517   /* TYPE and CLASS of the same declared type are type compatible,
 518      but have different characteristics.  */
 519   if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
 520       || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
 521     return 0;
 522
 523   return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
 524 }
 525
 526
 527 static int
 528 compare_rank (gfc_symbol *s1, gfc_symbol *s2)
 529 {
 530   gfc_array_spec *as1, *as2;
 531   int r1, r2;
 532
 533   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
 534     return 1;
 535
 536   as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
 537   as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
 538
 539   r1 = as1 ? as1->rank : 0;
 540   r2 = as2 ? as2->rank : 0;
 541
 542   if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
 543     return 0;                   /* Ranks differ.  */
 544
 545   return 1;
 546 }
 547
 548
 549 /* Given two symbols that are formal arguments, compare their ranks
 550    and types.  Returns nonzero if they have the same rank and type,
 551    zero otherwise.  */
 552
 553 static int
 554 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 555 {
 556   return compare_type (s1, s2) && compare_rank (s1, s2);
 557 }
 558
 559
 560 /* Given two symbols that are formal arguments, compare their types
 561    and rank and their formal interfaces if they are both dummy
 562    procedures.  Returns nonzero if the same, zero if different.  */
 563
 564 static int
 565 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
 566 {
 567   if (s1 == NULL || s2 == NULL)
 568     return s1 == s2 ? 1 : 0;
 569
 570   if (s1 == s2)
 571     return 1;
 572
 573   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
 574     return compare_type_rank (s1, s2);
 575
 576   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
 577     return 0;
 578
 579   /* At this point, both symbols are procedures.  It can happen that
 580      external procedures are compared, where one is identified by usage
 581      to be a function or subroutine but the other is not.  Check TKR
 582      nonetheless for these cases.  */
 583   if (s1->attr.function == 0 && s1->attr.subroutine == 0)
 584     return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
 585
 586   if (s2->attr.function == 0 && s2->attr.subroutine == 0)
 587     return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
 588
 589   /* Now the type of procedure has been identified.  */
 590   if (s1->attr.function != s2->attr.function
 591       || s1->attr.subroutine != s2->attr.subroutine)
 592     return 0;
 593
 594   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
 595     return 0;
 596
 597   /* Originally, gfortran recursed here to check the interfaces of passed
 598      procedures.  This is explicitly not required by the standard.  */
 599   return 1;
 600 }
 601
 602
 603 /* Given a formal argument list and a keyword name, search the list
 604    for that keyword.  Returns the correct symbol node if found, NULL
 605    if not found.  */
 606
 607 static gfc_symbol *
 608 find_keyword_arg (const char *name, gfc_formal_arglist *f)
 609 {
 610   for (; f; f = f->next)
 611     if (strcmp (f->sym->name, name) == 0)
 612       return f->sym;
 613
 614   return NULL;
 615 }
 616
 617
 618 /******** Interface checking subroutines **********/
 619
 620
 621 /* Given an operator interface and the operator, make sure that all
 622    interfaces for that operator are legal.  */
 623
 624 bool
 625 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
 626                               locus opwhere)
 627 {
 628   gfc_formal_arglist *formal;
 629   sym_intent i1, i2;
 630   bt t1, t2;
 631   int args, r1, r2, k1, k2;
 632
 633   gcc_assert (sym);
 634
 635   args = 0;
 636   t1 = t2 = BT_UNKNOWN;
 637   i1 = i2 = INTENT_UNKNOWN;
 638   r1 = r2 = -1;
 639   k1 = k2 = -1;
 640
 641   for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
 642     {
 643       gfc_symbol *fsym = formal->sym;
 644       if (fsym == NULL)
 645         {
 646           gfc_error ("Alternate return cannot appear in operator "
 647                      "interface at %L", &sym->declared_at);
 648           return false;
 649         }
 650       if (args == 0)
 651         {
 652           t1 = fsym->ts.type;
 653           i1 = fsym->attr.intent;
 654           r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
 655           k1 = fsym->ts.kind;
 656         }
 657       if (args == 1)
 658         {
 659           t2 = fsym->ts.type;
 660           i2 = fsym->attr.intent;
 661           r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
 662           k2 = fsym->ts.kind;
 663         }
 664       args++;
 665     }
 666
 667   /* Only +, - and .not. can be unary operators.
 668      .not. cannot be a binary operator.  */
 669   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
 670                                 && op != INTRINSIC_MINUS
 671                                 && op != INTRINSIC_NOT)
 672       || (args == 2 && op == INTRINSIC_NOT))
 673     {
 674       if (op == INTRINSIC_ASSIGN)
 675         gfc_error ("Assignment operator interface at %L must have "
 676                    "two arguments", &sym->declared_at);
 677       else
 678         gfc_error ("Operator interface at %L has the wrong number of arguments",
 679                    &sym->declared_at);
 680       return false;
 681     }
 682
 683   /* Check that intrinsics are mapped to functions, except
 684      INTRINSIC_ASSIGN which should map to a subroutine.  */
 685   if (op == INTRINSIC_ASSIGN)
 686     {
 687       gfc_formal_arglist *dummy_args;
 688
 689       if (!sym->attr.subroutine)
 690         {
 691           gfc_error ("Assignment operator interface at %L must be "
 692                      "a SUBROUTINE", &sym->declared_at);
 693           return false;
 694         }
 695
 696       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
 697          - First argument an array with different rank than second,
 698          - First argument is a scalar and second an array,
 699          - Types and kinds do not conform, or
 700          - First argument is of derived type.  */
 701       dummy_args = gfc_sym_get_dummy_args (sym);
 702       if (dummy_args->sym->ts.type != BT_DERIVED
 703           && dummy_args->sym->ts.type != BT_CLASS
 704           && (r2 == 0 || r1 == r2)
 705           && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
 706               || (gfc_numeric_ts (&dummy_args->sym->ts)
 707                   && gfc_numeric_ts (&dummy_args->next->sym->ts))))
 708         {
 709           gfc_error ("Assignment operator interface at %L must not redefine "
 710                      "an INTRINSIC type assignment", &sym->declared_at);
 711           return false;
 712         }
 713     }
 714   else
 715     {
 716       if (!sym->attr.function)
 717         {
 718           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
 719                      &sym->declared_at);
 720           return false;
 721         }
 722     }
 723
 724   /* Check intents on operator interfaces.  */
 725   if (op == INTRINSIC_ASSIGN)
 726     {
 727       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
 728         {
 729           gfc_error ("First argument of defined assignment at %L must be "
 730                      "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
 731           return false;
 732         }
 733
 734       if (i2 != INTENT_IN)
 735         {
 736           gfc_error ("Second argument of defined assignment at %L must be "
 737                      "INTENT(IN)", &sym->declared_at);
 738           return false;
 739         }
 740     }
 741   else
 742     {
 743       if (i1 != INTENT_IN)
 744         {
 745           gfc_error ("First argument of operator interface at %L must be "
 746                      "INTENT(IN)", &sym->declared_at);
 747           return false;
 748         }
 749
 750       if (args == 2 && i2 != INTENT_IN)
 751         {
 752           gfc_error ("Second argument of operator interface at %L must be "
 753                      "INTENT(IN)", &sym->declared_at);
 754           return false;
 755         }
 756     }
 757
 758   /* From now on, all we have to do is check that the operator definition
 759      doesn't conflict with an intrinsic operator. The rules for this
 760      game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
 761      as well as 12.3.2.1.1 of Fortran 2003:
 762
 763      "If the operator is an intrinsic-operator (R310), the number of
 764      function arguments shall be consistent with the intrinsic uses of
 765      that operator, and the types, kind type parameters, or ranks of the
 766      dummy arguments shall differ from those required for the intrinsic
 767      operation (7.1.2)."  */
 768
 769 #define IS_NUMERIC_TYPE(t) \
 770   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
 771
 772   /* Unary ops are easy, do them first.  */
 773   if (op == INTRINSIC_NOT)
 774     {
 775       if (t1 == BT_LOGICAL)
 776         goto bad_repl;
 777       else
 778         return true;
 779     }
 780
 781   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
 782     {
 783       if (IS_NUMERIC_TYPE (t1))
 784         goto bad_repl;
 785       else
 786         return true;
 787     }
 788
 789   /* Character intrinsic operators have same character kind, thus
 790      operator definitions with operands of different character kinds
 791      are always safe.  */
 792   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
 793     return true;
 794
 795   /* Intrinsic operators always perform on arguments of same rank,
 796      so different ranks is also always safe.  (rank == 0) is an exception
 797      to that, because all intrinsic operators are elemental.  */
 798   if (r1 != r2 && r1 != 0 && r2 != 0)
 799     return true;
 800
 801   switch (op)
 802   {
 803     case INTRINSIC_EQ:
 804     case INTRINSIC_EQ_OS:
 805     case INTRINSIC_NE:
 806     case INTRINSIC_NE_OS:
 807       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 808         goto bad_repl;
 809       /* Fall through.  */
 810
 811     case INTRINSIC_PLUS:
 812     case INTRINSIC_MINUS:
 813     case INTRINSIC_TIMES:
 814     case INTRINSIC_DIVIDE:
 815     case INTRINSIC_POWER:
 816       if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
 817         goto bad_repl;
 818       break;
 819
 820     case INTRINSIC_GT:
 821     case INTRINSIC_GT_OS:
 822     case INTRINSIC_GE:
 823     case INTRINSIC_GE_OS:
 824     case INTRINSIC_LT:
 825     case INTRINSIC_LT_OS:
 826     case INTRINSIC_LE:
 827     case INTRINSIC_LE_OS:
 828       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 829         goto bad_repl;
 830       if ((t1 == BT_INTEGER || t1 == BT_REAL)
 831           && (t2 == BT_INTEGER || t2 == BT_REAL))
 832         goto bad_repl;
 833       break;
 834
 835     case INTRINSIC_CONCAT:
 836       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 837         goto bad_repl;
 838       break;
 839
 840     case INTRINSIC_AND:
 841     case INTRINSIC_OR:
 842     case INTRINSIC_EQV:
 843     case INTRINSIC_NEQV:
 844       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
 845         goto bad_repl;
 846       break;
 847
 848     default:
 849       break;
 850   }
 851
 852   return true;
 853
 854 #undef IS_NUMERIC_TYPE
 855
 856 bad_repl:
 857   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
 858              &opwhere);
 859   return false;
 860 }
 861
 862
 863 /* Given a pair of formal argument lists, we see if the two lists can
 864    be distinguished by counting the number of nonoptional arguments of
 865    a given type/rank in f1 and seeing if there are less then that
 866    number of those arguments in f2 (including optional arguments).
 867    Since this test is asymmetric, it has to be called twice to make it
 868    symmetric. Returns nonzero if the argument lists are incompatible
 869    by this test. This subroutine implements rule 1 of section F03:16.2.3.
 870    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
 871
 872 static int
 873 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 874                   const char *p1, const char *p2)
 875 {
 876   int rc, ac1, ac2, i, j, k, n1;
 877   gfc_formal_arglist *f;
 878
 879   typedef struct
 880   {
 881     int flag;
 882     gfc_symbol *sym;
 883   }
 884   arginfo;
 885
 886   arginfo *arg;
 887
 888   n1 = 0;
 889
 890   for (f = f1; f; f = f->next)
 891     n1++;
 892
 893   /* Build an array of integers that gives the same integer to
 894      arguments of the same type/rank.  */
 895   arg = XCNEWVEC (arginfo, n1);
 896
 897   f = f1;
 898   for (i = 0; i < n1; i++, f = f->next)
 899     {
 900       arg[i].flag = -1;
 901       arg[i].sym = f->sym;
 902     }
 903
 904   k = 0;
 905
 906   for (i = 0; i < n1; i++)
 907     {
 908       if (arg[i].flag != -1)
 909         continue;
 910
 911       if (arg[i].sym && (arg[i].sym->attr.optional
 912                          || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
 913         continue;               /* Skip OPTIONAL and PASS arguments.  */
 914
 915       arg[i].flag = k;
 916
 917       /* Find other non-optional, non-pass arguments of the same type/rank.  */
 918       for (j = i + 1; j < n1; j++)
 919         if ((arg[j].sym == NULL
 920              || !(arg[j].sym->attr.optional
 921                   || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
 922             && (compare_type_rank_if (arg[i].sym, arg[j].sym)
 923                 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
 924           arg[j].flag = k;
 925
 926       k++;
 927     }
 928
 929   /* Now loop over each distinct type found in f1.  */
 930   k = 0;
 931   rc = 0;
 932
 933   for (i = 0; i < n1; i++)
 934     {
 935       if (arg[i].flag != k)
 936         continue;
 937
 938       ac1 = 1;
 939       for (j = i + 1; j < n1; j++)
 940         if (arg[j].flag == k)
 941           ac1++;
 942
 943       /* Count the number of non-pass arguments in f2 with that type,
 944          including those that are optional.  */
 945       ac2 = 0;
 946
 947       for (f = f2; f; f = f->next)
 948         if ((!p2 || strcmp (f->sym->name, p2) != 0)
 949             && (compare_type_rank_if (arg[i].sym, f->sym)
 950                 || compare_type_rank_if (f->sym, arg[i].sym)))
 951           ac2++;
 952
 953       if (ac1 > ac2)
 954         {
 955           rc = 1;
 956           break;
 957         }
 958
 959       k++;
 960     }
 961
 962   free (arg);
 963
 964   return rc;
 965 }
 966
 967
 968 /* Perform the correspondence test in rule (3) of F08:C1215.
 969    Returns zero if no argument is found that satisfies this rule,
 970    nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
 971    (if applicable).
 972
 973    This test is also not symmetric in f1 and f2 and must be called
 974    twice.  This test finds problems caused by sorting the actual
 975    argument list with keywords.  For example:
 976
 977    INTERFACE FOO
 978      SUBROUTINE F1(A, B)
 979        INTEGER :: A ; REAL :: B
 980      END SUBROUTINE F1
 981
 982      SUBROUTINE F2(B, A)
 983        INTEGER :: A ; REAL :: B
 984      END SUBROUTINE F1
 985    END INTERFACE FOO
 986
 987    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
 988
 989 static int
 990 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 991                         const char *p1, const char *p2)
 992 {
 993   gfc_formal_arglist *f2_save, *g;
 994   gfc_symbol *sym;
 995
 996   f2_save = f2;
 997
 998   while (f1)
 999     {
1000       if (f1->sym->attr.optional)
1001         goto next;
1002
1003       if (p1 && strcmp (f1->sym->name, p1) == 0)
1004         f1 = f1->next;
1005       if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
1006         f2 = f2->next;
1007
1008       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
1009                          || compare_type_rank (f2->sym, f1->sym))
1010           && !((gfc_option.allow_std & GFC_STD_F2008)
1011                && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
1012                    || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
1013         goto next;
1014
1015       /* Now search for a disambiguating keyword argument starting at
1016          the current non-match.  */
1017       for (g = f1; g; g = g->next)
1018         {
1019           if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
1020             continue;
1021
1022           sym = find_keyword_arg (g->sym->name, f2_save);
1023           if (sym == NULL || !compare_type_rank (g->sym, sym)
1024               || ((gfc_option.allow_std & GFC_STD_F2008)
1025                   && ((sym->attr.allocatable && g->sym->attr.pointer)
1026                       || (sym->attr.pointer && g->sym->attr.allocatable))))
1027             return 1;
1028         }
1029
1030     next:
1031       if (f1 != NULL)
1032         f1 = f1->next;
1033       if (f2 != NULL)
1034         f2 = f2->next;
1035     }
1036
1037   return 0;
1038 }
1039
1040
1041 static int
1042 symbol_rank (gfc_symbol *sym)
1043 {
1044   gfc_array_spec *as;
1045   as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as;
1046   return as ? as->rank : 0;
1047 }
1048
1049
1050 /* Check if the characteristics of two dummy arguments match,
1051    cf. F08:12.3.2.  */
1052
1053 static bool
1054 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1055                              bool type_must_agree, char *errmsg, int err_len)
1056 {
1057   if (s1 == NULL || s2 == NULL)
1058     return s1 == s2 ? true : false;
1059
1060   /* Check type and rank.  */
1061   if (type_must_agree)
1062     {
1063       if (!compare_type (s1, s2) || !compare_type (s2, s1))
1064         {
1065           snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
1066                     s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
1067           return false;
1068         }
1069       if (!compare_rank (s1, s2))
1070         {
1071           snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
1072                     s1->name, symbol_rank (s1), symbol_rank (s2));
1073           return false;
1074         }
1075     }
1076
1077   /* Check INTENT.  */
1078   if (s1->attr.intent != s2->attr.intent)
1079     {
1080       snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1081                 s1->name);
1082       return false;
1083     }
1084
1085   /* Check OPTIONAL attribute.  */
1086   if (s1->attr.optional != s2->attr.optional)
1087     {
1088       snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1089                 s1->name);
1090       return false;
1091     }
1092
1093   /* Check ALLOCATABLE attribute.  */
1094   if (s1->attr.allocatable != s2->attr.allocatable)
1095     {
1096       snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1097                 s1->name);
1098       return false;
1099     }
1100
1101   /* Check POINTER attribute.  */
1102   if (s1->attr.pointer != s2->attr.pointer)
1103     {
1104       snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1105                 s1->name);
1106       return false;
1107     }
1108
1109   /* Check TARGET attribute.  */
1110   if (s1->attr.target != s2->attr.target)
1111     {
1112       snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1113                 s1->name);
1114       return false;
1115     }
1116
1117   /* FIXME: Do more comprehensive testing of attributes, like e.g.
1118             ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc.  */
1119
1120   /* Check interface of dummy procedures.  */
1121   if (s1->attr.flavor == FL_PROCEDURE)
1122     {
1123       char err[200];
1124       if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1125                                    NULL, NULL))
1126         {
1127           snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
1128                     "'%s': %s", s1->name, err);
1129           return false;
1130         }
1131     }
1132
1133   /* Check string length.  */
1134   if (s1->ts.type == BT_CHARACTER
1135       && s1->ts.u.cl && s1->ts.u.cl->length
1136       && s2->ts.u.cl && s2->ts.u.cl->length)
1137     {
1138       int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1139                                           s2->ts.u.cl->length);
1140       switch (compval)
1141       {
1142         case -1:
1143         case  1:
1144         case -3:
1145           snprintf (errmsg, err_len, "Character length mismatch "
1146                     "in argument '%s'", s1->name);
1147           return false;
1148
1149         case -2:
1150           /* FIXME: Implement a warning for this case.
1151           gfc_warning ("Possible character length mismatch in argument '%s'",
1152                        s1->name);*/
1153           break;
1154
1155         case 0:
1156           break;
1157
1158         default:
1159           gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1160                               "%i of gfc_dep_compare_expr", compval);
1161           break;
1162       }
1163     }
1164
1165   /* Check array shape.  */
1166   if (s1->as && s2->as)
1167     {
1168       int i, compval;
1169       gfc_expr *shape1, *shape2;
1170
1171       if (s1->as->type != s2->as->type)
1172         {
1173           snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1174                     s1->name);
1175           return false;
1176         }
1177
1178       if (s1->as->type == AS_EXPLICIT)
1179         for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1180           {
1181             shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1182                                   gfc_copy_expr (s1->as->lower[i]));
1183             shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1184                                   gfc_copy_expr (s2->as->lower[i]));
1185             compval = gfc_dep_compare_expr (shape1, shape2);
1186             gfc_free_expr (shape1);
1187             gfc_free_expr (shape2);
1188             switch (compval)
1189             {
1190               case -1:
1191               case  1:
1192               case -3:
1193                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1194                           "argument '%s'", i + 1, s1->name);
1195                 return false;
1196
1197               case -2:
1198                 /* FIXME: Implement a warning for this case.
1199                 gfc_warning ("Possible shape mismatch in argument '%s'",
1200                             s1->name);*/
1201                 break;
1202
1203               case 0:
1204                 break;
1205
1206               default:
1207                 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1208                                     "result %i of gfc_dep_compare_expr",
1209                                     compval);
1210                 break;
1211             }
1212           }
1213     }
1214
1215   return true;
1216 }
1217
1218
1219 /* Check if the characteristics of two function results match,
1220    cf. F08:12.3.3.  */
1221
1222 static bool
1223 check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1224                               char *errmsg, int err_len)
1225 {
1226   gfc_symbol *r1, *r2;
1227
1228   if (s1->ts.interface && s1->ts.interface->result)
1229     r1 = s1->ts.interface->result;
1230   else
1231     r1 = s1->result ? s1->result : s1;
1232
1233   if (s2->ts.interface && s2->ts.interface->result)
1234     r2 = s2->ts.interface->result;
1235   else
1236     r2 = s2->result ? s2->result : s2;
1237
1238   if (r1->ts.type == BT_UNKNOWN)
1239     return true;
1240
1241   /* Check type and rank.  */
1242   if (!compare_type (r1, r2))
1243     {
1244       snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
1245                 gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1246       return false;
1247     }
1248   if (!compare_rank (r1, r2))
1249     {
1250       snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
1251                 symbol_rank (r1), symbol_rank (r2));
1252       return false;
1253     }
1254
1255   /* Check ALLOCATABLE attribute.  */
1256   if (r1->attr.allocatable != r2->attr.allocatable)
1257     {
1258       snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1259                 "function result");
1260       return false;
1261     }
1262
1263   /* Check POINTER attribute.  */
1264   if (r1->attr.pointer != r2->attr.pointer)
1265     {
1266       snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1267                 "function result");
1268       return false;
1269     }
1270
1271   /* Check CONTIGUOUS attribute.  */
1272   if (r1->attr.contiguous != r2->attr.contiguous)
1273     {
1274       snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1275                 "function result");
1276       return false;
1277     }
1278
1279   /* Check PROCEDURE POINTER attribute.  */
1280   if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1281     {
1282       snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1283                 "function result");
1284       return false;
1285     }
1286
1287   /* Check string length.  */
1288   if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1289     {
1290       if (r1->ts.deferred != r2->ts.deferred)
1291         {
1292           snprintf (errmsg, err_len, "Character length mismatch "
1293                     "in function result");
1294           return false;
1295         }
1296
1297       if (r1->ts.u.cl->length && r2->ts.u.cl->length)
1298         {
1299           int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1300                                               r2->ts.u.cl->length);
1301           switch (compval)
1302           {
1303             case -1:
1304             case  1:
1305             case -3:
1306               snprintf (errmsg, err_len, "Character length mismatch "
1307                         "in function result");
1308               return false;
1309
1310             case -2:
1311               /* FIXME: Implement a warning for this case.
1312               snprintf (errmsg, err_len, "Possible character length mismatch "
1313                         "in function result");*/
1314               break;
1315
1316             case 0:
1317               break;
1318
1319             default:
1320               gfc_internal_error ("check_result_characteristics (1): Unexpected "
1321                                   "result %i of gfc_dep_compare_expr", compval);
1322               break;
1323           }
1324         }
1325     }
1326
1327   /* Check array shape.  */
1328   if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1329     {
1330       int i, compval;
1331       gfc_expr *shape1, *shape2;
1332
1333       if (r1->as->type != r2->as->type)
1334         {
1335           snprintf (errmsg, err_len, "Shape mismatch in function result");
1336           return false;
1337         }
1338
1339       if (r1->as->type == AS_EXPLICIT)
1340         for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1341           {
1342             shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1343                                    gfc_copy_expr (r1->as->lower[i]));
1344             shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1345                                    gfc_copy_expr (r2->as->lower[i]));
1346             compval = gfc_dep_compare_expr (shape1, shape2);
1347             gfc_free_expr (shape1);
1348             gfc_free_expr (shape2);
1349             switch (compval)
1350             {
1351               case -1:
1352               case  1:
1353               case -3:
1354                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1355                           "function result", i + 1);
1356                 return false;
1357
1358               case -2:
1359                 /* FIXME: Implement a warning for this case.
1360                 gfc_warning ("Possible shape mismatch in return value");*/
1361                 break;
1362
1363               case 0:
1364                 break;
1365
1366               default:
1367                 gfc_internal_error ("check_result_characteristics (2): "
1368                                     "Unexpected result %i of "
1369                                     "gfc_dep_compare_expr", compval);
1370                 break;
1371             }
1372           }
1373     }
1374
1375   return true;
1376 }
1377
1378
1379 /* 'Compare' two formal interfaces associated with a pair of symbols.
1380    We return nonzero if there exists an actual argument list that
1381    would be ambiguous between the two interfaces, zero otherwise.
1382    'strict_flag' specifies whether all the characteristics are
1383    required to match, which is not the case for ambiguity checks.
1384    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
1385
1386 int
1387 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1388                         int generic_flag, int strict_flag,
1389                         char *errmsg, int err_len,
1390                         const char *p1, const char *p2)
1391 {
1392   gfc_formal_arglist *f1, *f2;
1393
1394   gcc_assert (name2 != NULL);
1395
1396   if (s1->attr.function && (s2->attr.subroutine
1397       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1398           && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1399     {
1400       if (errmsg != NULL)
1401         snprintf (errmsg, err_len, "'%s' is not a function", name2);
1402       return 0;
1403     }
1404
1405   if (s1->attr.subroutine && s2->attr.function)
1406     {
1407       if (errmsg != NULL)
1408         snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1409       return 0;
1410     }
1411
1412   /* Do strict checks on all characteristics
1413      (for dummy procedures and procedure pointer assignments).  */
1414   if (!generic_flag && strict_flag)
1415     {
1416       if (s1->attr.function && s2->attr.function)
1417         {
1418           /* If both are functions, check result characteristics.  */
1419           if (!check_result_characteristics (s1, s2, errmsg, err_len)
1420               || !check_result_characteristics (s2, s1, errmsg, err_len))
1421             return 0;
1422         }
1423
1424       if (s1->attr.pure && !s2->attr.pure)
1425         {
1426           snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1427           return 0;
1428         }
1429       if (s1->attr.elemental && !s2->attr.elemental)
1430         {
1431           snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1432           return 0;
1433         }
1434     }
1435
1436   if (s1->attr.if_source == IFSRC_UNKNOWN
1437       || s2->attr.if_source == IFSRC_UNKNOWN)
1438     return 1;
1439
1440   f1 = gfc_sym_get_dummy_args (s1);
1441   f2 = gfc_sym_get_dummy_args (s2);
1442
1443   if (f1 == NULL && f2 == NULL)
1444     return 1;                   /* Special case: No arguments.  */
1445
1446   if (generic_flag)
1447     {
1448       if (count_types_test (f1, f2, p1, p2)
1449           || count_types_test (f2, f1, p2, p1))
1450         return 0;
1451       if (generic_correspondence (f1, f2, p1, p2)
1452           || generic_correspondence (f2, f1, p2, p1))
1453         return 0;
1454     }
1455   else
1456     /* Perform the abbreviated correspondence test for operators (the
1457        arguments cannot be optional and are always ordered correctly).
1458        This is also done when comparing interfaces for dummy procedures and in
1459        procedure pointer assignments.  */
1460
1461     for (;;)
1462       {
1463         /* Check existence.  */
1464         if (f1 == NULL && f2 == NULL)
1465           break;
1466         if (f1 == NULL || f2 == NULL)
1467           {
1468             if (errmsg != NULL)
1469               snprintf (errmsg, err_len, "'%s' has the wrong number of "
1470                         "arguments", name2);
1471             return 0;
1472           }
1473
1474         if (UNLIMITED_POLY (f1->sym))
1475           goto next;
1476
1477         if (strict_flag)
1478           {
1479             /* Check all characteristics.  */
1480             if (!check_dummy_characteristics (f1->sym, f2->sym, true,
1481                                               errmsg, err_len))
1482               return 0;
1483           }
1484         else
1485           {
1486             /* Only check type and rank.  */
1487             if (!compare_type (f2->sym, f1->sym))
1488               {
1489                 if (errmsg != NULL)
1490                   snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
1491                             "(%s/%s)", f1->sym->name,
1492                             gfc_typename (&f1->sym->ts),
1493                             gfc_typename (&f2->sym->ts));
1494                 return 0;
1495               }
1496             if (!compare_rank (f2->sym, f1->sym))
1497               {
1498                 if (errmsg != NULL)
1499                   snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
1500                             "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
1501                             symbol_rank (f2->sym));
1502                 return 0;
1503               }
1504           }
1505 next:
1506         f1 = f1->next;
1507         f2 = f2->next;
1508       }
1509
1510   return 1;
1511 }
1512
1513
1514 /* Given a pointer to an interface pointer, remove duplicate
1515    interfaces and make sure that all symbols are either functions
1516    or subroutines, and all of the same kind.  Returns nonzero if
1517    something goes wrong.  */
1518
1519 static int
1520 check_interface0 (gfc_interface *p, const char *interface_name)
1521 {
1522   gfc_interface *psave, *q, *qlast;
1523
1524   psave = p;
1525   for (; p; p = p->next)
1526     {
1527       /* Make sure all symbols in the interface have been defined as
1528          functions or subroutines.  */
1529       if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1530            || !p->sym->attr.if_source)
1531           && p->sym->attr.flavor != FL_DERIVED)
1532         {
1533           if (p->sym->attr.external)
1534             gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1535                        p->sym->name, interface_name, &p->sym->declared_at);
1536           else
1537             gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1538                        "subroutine", p->sym->name, interface_name,
1539                       &p->sym->declared_at);
1540           return 1;
1541         }
1542
1543       /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
1544       if ((psave->sym->attr.function && !p->sym->attr.function
1545            && p->sym->attr.flavor != FL_DERIVED)
1546           || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1547         {
1548           if (p->sym->attr.flavor != FL_DERIVED)
1549             gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1550                        " or all FUNCTIONs", interface_name,
1551                        &p->sym->declared_at);
1552           else
1553             gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1554                        "generic name is also the name of a derived type",
1555                        interface_name, &p->sym->declared_at);
1556           return 1;
1557         }
1558
1559       /* F2003, C1207. F2008, C1207.  */
1560       if (p->sym->attr.proc == PROC_INTERNAL
1561           && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1562                               "'%s' in %s at %L", p->sym->name,
1563                               interface_name, &p->sym->declared_at))
1564         return 1;
1565     }
1566   p = psave;
1567
1568   /* Remove duplicate interfaces in this interface list.  */
1569   for (; p; p = p->next)
1570     {
1571       qlast = p;
1572
1573       for (q = p->next; q;)
1574         {
1575           if (p->sym != q->sym)
1576             {
1577               qlast = q;
1578               q = q->next;
1579             }
1580           else
1581             {
1582               /* Duplicate interface.  */
1583               qlast->next = q->next;
1584               free (q);
1585               q = qlast->next;
1586             }
1587         }
1588     }
1589
1590   return 0;
1591 }
1592
1593
1594 /* Check lists of interfaces to make sure that no two interfaces are
1595    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
1596
1597 static int
1598 check_interface1 (gfc_interface *p, gfc_interface *q0,
1599                   int generic_flag, const char *interface_name,
1600                   bool referenced)
1601 {
1602   gfc_interface *q;
1603   for (; p; p = p->next)
1604     for (q = q0; q; q = q->next)
1605       {
1606         if (p->sym == q->sym)
1607           continue;             /* Duplicates OK here.  */
1608
1609         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1610           continue;
1611
1612         if (p->sym->attr.flavor != FL_DERIVED
1613             && q->sym->attr.flavor != FL_DERIVED
1614             && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1615                                        generic_flag, 0, NULL, 0, NULL, NULL))
1616           {
1617             if (referenced)
1618               gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1619                          p->sym->name, q->sym->name, interface_name,
1620                          &p->where);
1621             else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1622               gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1623                            p->sym->name, q->sym->name, interface_name,
1624                            &p->where);
1625             else
1626               gfc_warning ("Although not referenced, '%s' has ambiguous "
1627                            "interfaces at %L", interface_name, &p->where);
1628             return 1;
1629           }
1630       }
1631   return 0;
1632 }
1633
1634
1635 /* Check the generic and operator interfaces of symbols to make sure
1636    that none of the interfaces conflict.  The check has to be done
1637    after all of the symbols are actually loaded.  */
1638
1639 static void
1640 check_sym_interfaces (gfc_symbol *sym)
1641 {
1642   char interface_name[100];
1643   gfc_interface *p;
1644
1645   if (sym->ns != gfc_current_ns)
1646     return;
1647
1648   if (sym->generic != NULL)
1649     {
1650       sprintf (interface_name, "generic interface '%s'", sym->name);
1651       if (check_interface0 (sym->generic, interface_name))
1652         return;
1653
1654       for (p = sym->generic; p; p = p->next)
1655         {
1656           if (p->sym->attr.mod_proc
1657               && (p->sym->attr.if_source != IFSRC_DECL
1658                   || p->sym->attr.procedure))
1659             {
1660               gfc_error ("'%s' at %L is not a module procedure",
1661                          p->sym->name, &p->where);
1662               return;
1663             }
1664         }
1665
1666       /* Originally, this test was applied to host interfaces too;
1667          this is incorrect since host associated symbols, from any
1668          source, cannot be ambiguous with local symbols.  */
1669       check_interface1 (sym->generic, sym->generic, 1, interface_name,
1670                         sym->attr.referenced || !sym->attr.use_assoc);
1671     }
1672 }
1673
1674
1675 static void
1676 check_uop_interfaces (gfc_user_op *uop)
1677 {
1678   char interface_name[100];
1679   gfc_user_op *uop2;
1680   gfc_namespace *ns;
1681
1682   sprintf (interface_name, "operator interface '%s'", uop->name);
1683   if (check_interface0 (uop->op, interface_name))
1684     return;
1685
1686   for (ns = gfc_current_ns; ns; ns = ns->parent)
1687     {
1688       uop2 = gfc_find_uop (uop->name, ns);
1689       if (uop2 == NULL)
1690         continue;
1691
1692       check_interface1 (uop->op, uop2->op, 0,
1693                         interface_name, true);
1694     }
1695 }
1696
1697 /* Given an intrinsic op, return an equivalent op if one exists,
1698    or INTRINSIC_NONE otherwise.  */
1699
1700 gfc_intrinsic_op
1701 gfc_equivalent_op (gfc_intrinsic_op op)
1702 {
1703   switch(op)
1704     {
1705     case INTRINSIC_EQ:
1706       return INTRINSIC_EQ_OS;
1707
1708     case INTRINSIC_EQ_OS:
1709       return INTRINSIC_EQ;
1710
1711     case INTRINSIC_NE:
1712       return INTRINSIC_NE_OS;
1713
1714     case INTRINSIC_NE_OS:
1715       return INTRINSIC_NE;
1716
1717     case INTRINSIC_GT:
1718       return INTRINSIC_GT_OS;
1719
1720     case INTRINSIC_GT_OS:
1721       return INTRINSIC_GT;
1722
1723     case INTRINSIC_GE:
1724       return INTRINSIC_GE_OS;
1725
1726     case INTRINSIC_GE_OS:
1727       return INTRINSIC_GE;
1728
1729     case INTRINSIC_LT:
1730       return INTRINSIC_LT_OS;
1731
1732     case INTRINSIC_LT_OS:
1733       return INTRINSIC_LT;
1734
1735     case INTRINSIC_LE:
1736       return INTRINSIC_LE_OS;
1737
1738     case INTRINSIC_LE_OS:
1739       return INTRINSIC_LE;
1740
1741     default:
1742       return INTRINSIC_NONE;
1743     }
1744 }
1745
1746 /* For the namespace, check generic, user operator and intrinsic
1747    operator interfaces for consistency and to remove duplicate
1748    interfaces.  We traverse the whole namespace, counting on the fact
1749    that most symbols will not have generic or operator interfaces.  */
1750
1751 void
1752 gfc_check_interfaces (gfc_namespace *ns)
1753 {
1754   gfc_namespace *old_ns, *ns2;
1755   char interface_name[100];
1756   int i;
1757
1758   old_ns = gfc_current_ns;
1759   gfc_current_ns = ns;
1760
1761   gfc_traverse_ns (ns, check_sym_interfaces);
1762
1763   gfc_traverse_user_op (ns, check_uop_interfaces);
1764
1765   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1766     {
1767       if (i == INTRINSIC_USER)
1768         continue;
1769
1770       if (i == INTRINSIC_ASSIGN)
1771         strcpy (interface_name, "intrinsic assignment operator");
1772       else
1773         sprintf (interface_name, "intrinsic '%s' operator",
1774                  gfc_op2string ((gfc_intrinsic_op) i));
1775
1776       if (check_interface0 (ns->op[i], interface_name))
1777         continue;
1778
1779       if (ns->op[i])
1780         gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1781                                       ns->op[i]->where);
1782
1783       for (ns2 = ns; ns2; ns2 = ns2->parent)
1784         {
1785           gfc_intrinsic_op other_op;
1786
1787           if (check_interface1 (ns->op[i], ns2->op[i], 0,
1788                                 interface_name, true))
1789             goto done;
1790
1791           /* i should be gfc_intrinsic_op, but has to be int with this cast
1792              here for stupid C++ compatibility rules.  */
1793           other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1794           if (other_op != INTRINSIC_NONE
1795             &&  check_interface1 (ns->op[i], ns2->op[other_op],
1796                                   0, interface_name, true))
1797             goto done;
1798         }
1799     }
1800
1801 done:
1802   gfc_current_ns = old_ns;
1803 }
1804
1805
1806 /* Given a symbol of a formal argument list and an expression, if the
1807    formal argument is allocatable, check that the actual argument is
1808    allocatable. Returns nonzero if compatible, zero if not compatible.  */
1809
1810 static int
1811 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1812 {
1813   symbol_attribute attr;
1814
1815   if (formal->attr.allocatable
1816       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1817     {
1818       attr = gfc_expr_attr (actual);
1819       if (!attr.allocatable)
1820         return 0;
1821     }
1822
1823   return 1;
1824 }
1825
1826
1827 /* Given a symbol of a formal argument list and an expression, if the
1828    formal argument is a pointer, see if the actual argument is a
1829    pointer. Returns nonzero if compatible, zero if not compatible.  */
1830
1831 static int
1832 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1833 {
1834   symbol_attribute attr;
1835
1836   if (formal->attr.pointer
1837       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
1838           && CLASS_DATA (formal)->attr.class_pointer))
1839     {
1840       attr = gfc_expr_attr (actual);
1841
1842       /* Fortran 2008 allows non-pointer actual arguments.  */
1843       if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1844         return 2;
1845
1846       if (!attr.pointer)
1847         return 0;
1848     }
1849
1850   return 1;
1851 }
1852
1853
1854 /* Emit clear error messages for rank mismatch.  */
1855
1856 static void
1857 argument_rank_mismatch (const char *name, locus *where,
1858                         int rank1, int rank2)
1859 {
1860
1861   /* TS 29113, C407b.  */
1862   if (rank2 == -1)
1863     {
1864       gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1865                  " '%s' has assumed-rank", where, name);
1866     }
1867   else if (rank1 == 0)
1868     {
1869       gfc_error ("Rank mismatch in argument '%s' at %L "
1870                  "(scalar and rank-%d)", name, where, rank2);
1871     }
1872   else if (rank2 == 0)
1873     {
1874       gfc_error ("Rank mismatch in argument '%s' at %L "
1875                  "(rank-%d and scalar)", name, where, rank1);
1876     }
1877   else
1878     {
1879       gfc_error ("Rank mismatch in argument '%s' at %L "
1880                  "(rank-%d and rank-%d)", name, where, rank1, rank2);
1881     }
1882 }
1883
1884
1885 /* Given a symbol of a formal argument list and an expression, see if
1886    the two are compatible as arguments.  Returns nonzero if
1887    compatible, zero if not compatible.  */
1888
1889 static int
1890 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1891                    int ranks_must_agree, int is_elemental, locus *where)
1892 {
1893   gfc_ref *ref;
1894   bool rank_check, is_pointer;
1895
1896   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1897      procs c_f_pointer or c_f_procpointer, and we need to accept most
1898      pointers the user could give us.  This should allow that.  */
1899   if (formal->ts.type == BT_VOID)
1900     return 1;
1901
1902   if (formal->ts.type == BT_DERIVED
1903       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1904       && actual->ts.type == BT_DERIVED
1905       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1906     return 1;
1907
1908   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1909     /* Make sure the vtab symbol is present when
1910        the module variables are generated.  */
1911     gfc_find_derived_vtab (actual->ts.u.derived);
1912
1913   if (actual->ts.type == BT_PROCEDURE)
1914     {
1915       char err[200];
1916       gfc_symbol *act_sym = actual->symtree->n.sym;
1917
1918       if (formal->attr.flavor != FL_PROCEDURE)
1919         {
1920           if (where)
1921             gfc_error ("Invalid procedure argument at %L", &actual->where);
1922           return 0;
1923         }
1924
1925       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1926                                    sizeof(err), NULL, NULL))
1927         {
1928           if (where)
1929             gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1930                        formal->name, &actual->where, err);
1931           return 0;
1932         }
1933
1934       if (formal->attr.function && !act_sym->attr.function)
1935         {
1936           gfc_add_function (&act_sym->attr, act_sym->name,
1937           &act_sym->declared_at);
1938           if (act_sym->ts.type == BT_UNKNOWN
1939               && !gfc_set_default_type (act_sym, 1, act_sym->ns))
1940             return 0;
1941         }
1942       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1943         gfc_add_subroutine (&act_sym->attr, act_sym->name,
1944                             &act_sym->declared_at);
1945
1946       return 1;
1947     }
1948
1949   /* F2008, C1241.  */
1950   if (formal->attr.pointer && formal->attr.contiguous
1951       && !gfc_is_simply_contiguous (actual, true))
1952     {
1953       if (where)
1954         gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1955                    "must be simply contiguous", formal->name, &actual->where);
1956       return 0;
1957     }
1958
1959   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1960       && actual->ts.type != BT_HOLLERITH
1961       && formal->ts.type != BT_ASSUMED
1962       && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
1963       && !gfc_compare_types (&formal->ts, &actual->ts)
1964       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
1965            && gfc_compare_derived_types (formal->ts.u.derived,
1966                                          CLASS_DATA (actual)->ts.u.derived)))
1967     {
1968       if (where)
1969         gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1970                    formal->name, &actual->where, gfc_typename (&actual->ts),
1971                    gfc_typename (&formal->ts));
1972       return 0;
1973     }
1974
1975   /* F2008, 12.5.2.5; IR F08/0073.  */
1976   if (formal->ts.type == BT_CLASS && formal->attr.class_ok
1977       && actual->expr_type != EXPR_NULL
1978       && ((CLASS_DATA (formal)->attr.class_pointer
1979            && !formal->attr.intent == INTENT_IN)
1980           || CLASS_DATA (formal)->attr.allocatable))
1981     {
1982       if (actual->ts.type != BT_CLASS)
1983         {
1984           if (where)
1985             gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1986                         formal->name, &actual->where);
1987           return 0;
1988         }
1989
1990       if (!gfc_expr_attr (actual).class_ok)
1991         return 0;
1992
1993       if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
1994           && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
1995                                          CLASS_DATA (formal)->ts.u.derived))
1996         {
1997           if (where)
1998             gfc_error ("Actual argument to '%s' at %L must have the same "
1999                        "declared type", formal->name, &actual->where);
2000           return 0;
2001         }
2002     }
2003
2004   /* F08: 12.5.2.5 Allocatable and pointer dummy variables.  However, this
2005      is necessary also for F03, so retain error for both.
2006      NOTE: Other type/kind errors pre-empt this error.  Since they are F03
2007      compatible, no attempt has been made to channel to this one.  */
2008   if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
2009       && (CLASS_DATA (formal)->attr.allocatable
2010           ||CLASS_DATA (formal)->attr.class_pointer))
2011     {
2012       if (where)
2013         gfc_error ("Actual argument to '%s' at %L must be unlimited "
2014                    "polymorphic since the formal argument is a "
2015                    "pointer or allocatable unlimited polymorphic "
2016                    "entity [F2008: 12.5.2.5]", formal->name,
2017                    &actual->where);
2018       return 0;
2019     }
2020
2021   if (formal->attr.codimension && !gfc_is_coarray (actual))
2022     {
2023       if (where)
2024         gfc_error ("Actual argument to '%s' at %L must be a coarray",
2025                        formal->name, &actual->where);
2026       return 0;
2027     }
2028
2029   if (formal->attr.codimension && formal->attr.allocatable)
2030     {
2031       gfc_ref *last = NULL;
2032
2033       for (ref = actual->ref; ref; ref = ref->next)
2034         if (ref->type == REF_COMPONENT)
2035           last = ref;
2036
2037       /* F2008, 12.5.2.6.  */
2038       if ((last && last->u.c.component->as->corank != formal->as->corank)
2039           || (!last
2040               && actual->symtree->n.sym->as->corank != formal->as->corank))
2041         {
2042           if (where)
2043             gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
2044                    formal->name, &actual->where, formal->as->corank,
2045                    last ? last->u.c.component->as->corank
2046                         : actual->symtree->n.sym->as->corank);
2047           return 0;
2048         }
2049     }
2050
2051   if (formal->attr.codimension)
2052     {
2053       /* F2008, 12.5.2.8.  */
2054       if (formal->attr.dimension
2055           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2056           && gfc_expr_attr (actual).dimension
2057           && !gfc_is_simply_contiguous (actual, true))
2058         {
2059           if (where)
2060             gfc_error ("Actual argument to '%s' at %L must be simply "
2061                        "contiguous", formal->name, &actual->where);
2062           return 0;
2063         }
2064
2065       /* F2008, C1303 and C1304.  */
2066       if (formal->attr.intent != INTENT_INOUT
2067           && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2068                && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2069                && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2070               || formal->attr.lock_comp))
2071
2072         {
2073           if (where)
2074             gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
2075                        "which is LOCK_TYPE or has a LOCK_TYPE component",
2076                        formal->name, &actual->where);
2077           return 0;
2078         }
2079     }
2080
2081   /* F2008, C1239/C1240.  */
2082   if (actual->expr_type == EXPR_VARIABLE
2083       && (actual->symtree->n.sym->attr.asynchronous
2084          || actual->symtree->n.sym->attr.volatile_)
2085       &&  (formal->attr.asynchronous || formal->attr.volatile_)
2086       && actual->rank && !gfc_is_simply_contiguous (actual, true)
2087       && ((formal->as->type != AS_ASSUMED_SHAPE
2088            && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
2089           || formal->attr.contiguous))
2090     {
2091       if (where)
2092         gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
2093                    "assumed-rank array without CONTIGUOUS attribute - as actual"
2094                    " argument at %L is not simply contiguous and both are "
2095                    "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
2096       return 0;
2097     }
2098
2099   if (formal->attr.allocatable && !formal->attr.codimension
2100       && gfc_expr_attr (actual).codimension)
2101     {
2102       if (formal->attr.intent == INTENT_OUT)
2103         {
2104           if (where)
2105             gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2106                        "INTENT(OUT) dummy argument '%s'", &actual->where,
2107                        formal->name);
2108             return 0;
2109         }
2110       else if (gfc_option.warn_surprising && where
2111                && formal->attr.intent != INTENT_IN)
2112         gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2113                      "argument '%s', which is invalid if the allocation status"
2114                      " is modified",  &actual->where, formal->name);
2115     }
2116
2117   /* If the rank is the same or the formal argument has assumed-rank.  */
2118   if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2119     return 1;
2120
2121   if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
2122         && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
2123     return 1;
2124
2125   rank_check = where != NULL && !is_elemental && formal->as
2126                && (formal->as->type == AS_ASSUMED_SHAPE
2127                    || formal->as->type == AS_DEFERRED)
2128                && actual->expr_type != EXPR_NULL;
2129
2130   /* Skip rank checks for NO_ARG_CHECK.  */
2131   if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2132     return 1;
2133
2134   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
2135   if (rank_check || ranks_must_agree
2136       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2137       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2138       || (actual->rank == 0
2139           && ((formal->ts.type == BT_CLASS
2140                && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2141               || (formal->ts.type != BT_CLASS
2142                    && formal->as->type == AS_ASSUMED_SHAPE))
2143           && actual->expr_type != EXPR_NULL)
2144       || (actual->rank == 0 && formal->attr.dimension
2145           && gfc_is_coindexed (actual)))
2146     {
2147       if (where)
2148         argument_rank_mismatch (formal->name, &actual->where,
2149                                 symbol_rank (formal), actual->rank);
2150       return 0;
2151     }
2152   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2153     return 1;
2154
2155   /* At this point, we are considering a scalar passed to an array.   This
2156      is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2157      - if the actual argument is (a substring of) an element of a
2158        non-assumed-shape/non-pointer/non-polymorphic array; or
2159      - (F2003) if the actual argument is of type character of default/c_char
2160        kind.  */
2161
2162   is_pointer = actual->expr_type == EXPR_VARIABLE
2163                ? actual->symtree->n.sym->attr.pointer : false;
2164
2165   for (ref = actual->ref; ref; ref = ref->next)
2166     {
2167       if (ref->type == REF_COMPONENT)
2168         is_pointer = ref->u.c.component->attr.pointer;
2169       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2170                && ref->u.ar.dimen > 0
2171                && (!ref->next
2172                    || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2173         break;
2174     }
2175
2176   if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2177     {
2178       if (where)
2179         gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2180                    "at %L", formal->name, &actual->where);
2181       return 0;
2182     }
2183
2184   if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2185       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2186     {
2187       if (where)
2188         gfc_error ("Element of assumed-shaped or pointer "
2189                    "array passed to array dummy argument '%s' at %L",
2190                    formal->name, &actual->where);
2191       return 0;
2192     }
2193
2194   if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2195       && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2196     {
2197       if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2198         {
2199           if (where)
2200             gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2201                        "CHARACTER actual argument with array dummy argument "
2202                        "'%s' at %L", formal->name, &actual->where);
2203           return 0;
2204         }
2205
2206       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2207         {
2208           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2209                      "array dummy argument '%s' at %L",
2210                      formal->name, &actual->where);
2211           return 0;
2212         }
2213       else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
2214         return 0;
2215       else
2216         return 1;
2217     }
2218
2219   if (ref == NULL && actual->expr_type != EXPR_NULL)
2220     {
2221       if (where)
2222         argument_rank_mismatch (formal->name, &actual->where,
2223                                 symbol_rank (formal), actual->rank);
2224       return 0;
2225     }
2226
2227   return 1;
2228 }
2229
2230
2231 /* Returns the storage size of a symbol (formal argument) or
2232    zero if it cannot be determined.  */
2233
2234 static unsigned long
2235 get_sym_storage_size (gfc_symbol *sym)
2236 {
2237   int i;
2238   unsigned long strlen, elements;
2239
2240   if (sym->ts.type == BT_CHARACTER)
2241     {
2242       if (sym->ts.u.cl && sym->ts.u.cl->length
2243           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2244         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2245       else
2246         return 0;
2247     }
2248   else
2249     strlen = 1;
2250
2251   if (symbol_rank (sym) == 0)
2252     return strlen;
2253
2254   elements = 1;
2255   if (sym->as->type != AS_EXPLICIT)
2256     return 0;
2257   for (i = 0; i < sym->as->rank; i++)
2258     {
2259       if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2260           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2261         return 0;
2262
2263       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2264                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2265     }
2266
2267   return strlen*elements;
2268 }
2269
2270
2271 /* Returns the storage size of an expression (actual argument) or
2272    zero if it cannot be determined. For an array element, it returns
2273    the remaining size as the element sequence consists of all storage
2274    units of the actual argument up to the end of the array.  */
2275
2276 static unsigned long
2277 get_expr_storage_size (gfc_expr *e)
2278 {
2279   int i;
2280   long int strlen, elements;
2281   long int substrlen = 0;
2282   bool is_str_storage = false;
2283   gfc_ref *ref;
2284
2285   if (e == NULL)
2286     return 0;
2287
2288   if (e->ts.type == BT_CHARACTER)
2289     {
2290       if (e->ts.u.cl && e->ts.u.cl->length
2291           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2292         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2293       else if (e->expr_type == EXPR_CONSTANT
2294                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2295         strlen = e->value.character.length;
2296       else
2297         return 0;
2298     }
2299   else
2300     strlen = 1; /* Length per element.  */
2301
2302   if (e->rank == 0 && !e->ref)
2303     return strlen;
2304
2305   elements = 1;
2306   if (!e->ref)
2307     {
2308       if (!e->shape)
2309         return 0;
2310       for (i = 0; i < e->rank; i++)
2311         elements *= mpz_get_si (e->shape[i]);
2312       return elements*strlen;
2313     }
2314
2315   for (ref = e->ref; ref; ref = ref->next)
2316     {
2317       if (ref->type == REF_SUBSTRING && ref->u.ss.start
2318           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2319         {
2320           if (is_str_storage)
2321             {
2322               /* The string length is the substring length.
2323                  Set now to full string length.  */
2324               if (!ref->u.ss.length || !ref->u.ss.length->length
2325                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2326                 return 0;
2327
2328               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2329             }
2330           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2331           continue;
2332         }
2333
2334       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2335         for (i = 0; i < ref->u.ar.dimen; i++)
2336           {
2337             long int start, end, stride;
2338             stride = 1;
2339
2340             if (ref->u.ar.stride[i])
2341               {
2342                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2343                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2344                 else
2345                   return 0;
2346               }
2347
2348             if (ref->u.ar.start[i])
2349               {
2350                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2351                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2352                 else
2353                   return 0;
2354               }
2355             else if (ref->u.ar.as->lower[i]
2356                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2357               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2358             else
2359               return 0;
2360
2361             if (ref->u.ar.end[i])
2362               {
2363                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2364                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2365                 else
2366                   return 0;
2367               }
2368             else if (ref->u.ar.as->upper[i]
2369                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2370               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2371             else
2372               return 0;
2373
2374             elements *= (end - start)/stride + 1L;
2375           }
2376       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
2377         for (i = 0; i < ref->u.ar.as->rank; i++)
2378           {
2379             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2380                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2381                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2382               elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2383                           - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2384                           + 1L;
2385             else
2386               return 0;
2387           }
2388       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2389                && e->expr_type == EXPR_VARIABLE)
2390         {
2391           if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2392               || e->symtree->n.sym->attr.pointer)
2393             {
2394               elements = 1;
2395               continue;
2396             }
2397
2398           /* Determine the number of remaining elements in the element
2399              sequence for array element designators.  */
2400           is_str_storage = true;
2401           for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2402             {
2403               if (ref->u.ar.start[i] == NULL
2404                   || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2405                   || ref->u.ar.as->upper[i] == NULL
2406                   || ref->u.ar.as->lower[i] == NULL
2407                   || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2408                   || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2409                 return 0;
2410
2411               elements
2412                    = elements
2413                      * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2414                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2415                         + 1L)
2416                      - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2417                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2418             }
2419         }
2420     }
2421
2422   if (substrlen)
2423     return (is_str_storage) ? substrlen + (elements-1)*strlen
2424                             : elements*strlen;
2425   else
2426     return elements*strlen;
2427 }
2428
2429
2430 /* Given an expression, check whether it is an array section
2431    which has a vector subscript. If it has, one is returned,
2432    otherwise zero.  */
2433
2434 int
2435 gfc_has_vector_subscript (gfc_expr *e)
2436 {
2437   int i;
2438   gfc_ref *ref;
2439
2440   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2441     return 0;
2442
2443   for (ref = e->ref; ref; ref = ref->next)
2444     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2445       for (i = 0; i < ref->u.ar.dimen; i++)
2446         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2447           return 1;
2448
2449   return 0;
2450 }
2451
2452
2453 /* Given formal and actual argument lists, see if they are compatible.
2454    If they are compatible, the actual argument list is sorted to
2455    correspond with the formal list, and elements for missing optional
2456    arguments are inserted. If WHERE pointer is nonnull, then we issue
2457    errors when things don't match instead of just returning the status
2458    code.  */
2459
2460 static int
2461 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2462                        int ranks_must_agree, int is_elemental, locus *where)
2463 {
2464   gfc_actual_arglist **new_arg, *a, *actual, temp;
2465   gfc_formal_arglist *f;
2466   int i, n, na;
2467   unsigned long actual_size, formal_size;
2468   bool full_array = false;
2469
2470   actual = *ap;
2471
2472   if (actual == NULL && formal == NULL)
2473     return 1;
2474
2475   n = 0;
2476   for (f = formal; f; f = f->next)
2477     n++;
2478
2479   new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2480
2481   for (i = 0; i < n; i++)
2482     new_arg[i] = NULL;
2483
2484   na = 0;
2485   f = formal;
2486   i = 0;
2487
2488   for (a = actual; a; a = a->next, f = f->next)
2489     {
2490       /* Look for keywords but ignore g77 extensions like %VAL.  */
2491       if (a->name != NULL && a->name[0] != '%')
2492         {
2493           i = 0;
2494           for (f = formal; f; f = f->next, i++)
2495             {
2496               if (f->sym == NULL)
2497                 continue;
2498               if (strcmp (f->sym->name, a->name) == 0)
2499                 break;
2500             }
2501
2502           if (f == NULL)
2503             {
2504               if (where)
2505                 gfc_error ("Keyword argument '%s' at %L is not in "
2506                            "the procedure", a->name, &a->expr->where);
2507               return 0;
2508             }
2509
2510           if (new_arg[i] != NULL)
2511             {
2512               if (where)
2513                 gfc_error ("Keyword argument '%s' at %L is already associated "
2514                            "with another actual argument", a->name,
2515                            &a->expr->where);
2516               return 0;
2517             }
2518         }
2519
2520       if (f == NULL)
2521         {
2522           if (where)
2523             gfc_error ("More actual than formal arguments in procedure "
2524                        "call at %L", where);
2525
2526           return 0;
2527         }
2528
2529       if (f->sym == NULL && a->expr == NULL)
2530         goto match;
2531
2532       if (f->sym == NULL)
2533         {
2534           if (where)
2535             gfc_error ("Missing alternate return spec in subroutine call "
2536                        "at %L", where);
2537           return 0;
2538         }
2539
2540       if (a->expr == NULL)
2541         {
2542           if (where)
2543             gfc_error ("Unexpected alternate return spec in subroutine "
2544                        "call at %L", where);
2545           return 0;
2546         }
2547
2548       /* Make sure that intrinsic vtables exist for calls to unlimited
2549          polymorphic formal arguments.  */
2550       if (UNLIMITED_POLY (f->sym)
2551           && a->expr->ts.type != BT_DERIVED
2552           && a->expr->ts.type != BT_CLASS)
2553         gfc_find_intrinsic_vtab (&a->expr->ts);
2554
2555       if (a->expr->expr_type == EXPR_NULL
2556           && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
2557                && (f->sym->attr.allocatable || !f->sym->attr.optional
2558                    || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2559               || (f->sym->ts.type == BT_CLASS
2560                   && !CLASS_DATA (f->sym)->attr.class_pointer
2561                   && (CLASS_DATA (f->sym)->attr.allocatable
2562                       || !f->sym->attr.optional
2563                       || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
2564         {
2565           if (where
2566               && (!f->sym->attr.optional
2567                   || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
2568                   || (f->sym->ts.type == BT_CLASS
2569                          && CLASS_DATA (f->sym)->attr.allocatable)))
2570             gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2571                        where, f->sym->name);
2572           else if (where)
2573             gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2574                        "dummy '%s'", where, f->sym->name);
2575
2576           return 0;
2577         }
2578
2579       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2580                               is_elemental, where))
2581         return 0;
2582
2583       /* TS 29113, 6.3p2.  */
2584       if (f->sym->ts.type == BT_ASSUMED
2585           && (a->expr->ts.type == BT_DERIVED
2586               || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2587         {
2588           gfc_namespace *f2k_derived;
2589
2590           f2k_derived = a->expr->ts.type == BT_DERIVED
2591                         ? a->expr->ts.u.derived->f2k_derived
2592                         : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2593
2594           if (f2k_derived
2595               && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
2596             {
2597               gfc_error ("Actual argument at %L to assumed-type dummy is of "
2598                          "derived type with type-bound or FINAL procedures",
2599                          &a->expr->where);
2600               return false;
2601             }
2602         }
2603
2604       /* Special case for character arguments.  For allocatable, pointer
2605          and assumed-shape dummies, the string length needs to match
2606          exactly.  */
2607       if (a->expr->ts.type == BT_CHARACTER
2608            && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2609            && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2610            && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2611            && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2612            && (f->sym->attr.pointer || f->sym->attr.allocatable
2613                || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2614            && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2615                         f->sym->ts.u.cl->length->value.integer) != 0))
2616          {
2617            if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2618              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2619                           "argument and pointer or allocatable dummy argument "
2620                           "'%s' at %L",
2621                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2622                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2623                           f->sym->name, &a->expr->where);
2624            else if (where)
2625              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2626                           "argument and assumed-shape dummy argument '%s' "
2627                           "at %L",
2628                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2629                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2630                           f->sym->name, &a->expr->where);
2631            return 0;
2632          }
2633
2634       if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2635             && f->sym->ts.deferred != a->expr->ts.deferred
2636             && a->expr->ts.type == BT_CHARACTER)
2637         {
2638           if (where)
2639             gfc_error ("Actual argument at %L to allocatable or "
2640                        "pointer dummy argument '%s' must have a deferred "
2641                        "length type parameter if and only if the dummy has one",
2642                        &a->expr->where, f->sym->name);
2643           return 0;
2644         }
2645
2646       if (f->sym->ts.type == BT_CLASS)
2647         goto skip_size_check;
2648
2649       actual_size = get_expr_storage_size (a->expr);
2650       formal_size = get_sym_storage_size (f->sym);
2651       if (actual_size != 0 && actual_size < formal_size
2652           && a->expr->ts.type != BT_PROCEDURE
2653           && f->sym->attr.flavor != FL_PROCEDURE)
2654         {
2655           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2656             gfc_warning ("Character length of actual argument shorter "
2657                          "than of dummy argument '%s' (%lu/%lu) at %L",
2658                          f->sym->name, actual_size, formal_size,
2659                          &a->expr->where);
2660           else if (where)
2661             gfc_warning ("Actual argument contains too few "
2662                          "elements for dummy argument '%s' (%lu/%lu) at %L",
2663                          f->sym->name, actual_size, formal_size,
2664                          &a->expr->where);
2665           return  0;
2666         }
2667
2668      skip_size_check:
2669
2670       /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2671          argument is provided for a procedure pointer formal argument.  */
2672       if (f->sym->attr.proc_pointer
2673           && !((a->expr->expr_type == EXPR_VARIABLE
2674                 && a->expr->symtree->n.sym->attr.proc_pointer)
2675                || (a->expr->expr_type == EXPR_FUNCTION
2676                    && a->expr->symtree->n.sym->result->attr.proc_pointer)
2677                || gfc_is_proc_ptr_comp (a->expr)))
2678         {
2679           if (where)
2680             gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2681                        f->sym->name, &a->expr->where);
2682           return 0;
2683         }
2684
2685       /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2686          provided for a procedure formal argument.  */
2687       if (f->sym->attr.flavor == FL_PROCEDURE
2688           && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
2689         {
2690           if (where)
2691             gfc_error ("Expected a procedure for argument '%s' at %L",
2692                        f->sym->name, &a->expr->where);
2693           return 0;
2694         }
2695
2696       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2697           && a->expr->expr_type == EXPR_VARIABLE
2698           && a->expr->symtree->n.sym->as
2699           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2700           && (a->expr->ref == NULL
2701               || (a->expr->ref->type == REF_ARRAY
2702                   && a->expr->ref->u.ar.type == AR_FULL)))
2703         {
2704           if (where)
2705             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2706                        " array at %L", f->sym->name, where);
2707           return 0;
2708         }
2709
2710       if (a->expr->expr_type != EXPR_NULL
2711           && compare_pointer (f->sym, a->expr) == 0)
2712         {
2713           if (where)
2714             gfc_error ("Actual argument for '%s' must be a pointer at %L",
2715                        f->sym->name, &a->expr->where);
2716           return 0;
2717         }
2718
2719       if (a->expr->expr_type != EXPR_NULL
2720           && (gfc_option.allow_std & GFC_STD_F2008) == 0
2721           && compare_pointer (f->sym, a->expr) == 2)
2722         {
2723           if (where)
2724             gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2725                        "pointer dummy '%s'", &a->expr->where,f->sym->name);
2726           return 0;
2727         }
2728
2729
2730       /* Fortran 2008, C1242.  */
2731       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2732         {
2733           if (where)
2734             gfc_error ("Coindexed actual argument at %L to pointer "
2735                        "dummy '%s'",
2736                        &a->expr->where, f->sym->name);
2737           return 0;
2738         }
2739
2740       /* Fortran 2008, 12.5.2.5 (no constraint).  */
2741       if (a->expr->expr_type == EXPR_VARIABLE
2742           && f->sym->attr.intent != INTENT_IN
2743           && f->sym->attr.allocatable
2744           && gfc_is_coindexed (a->expr))
2745         {
2746           if (where)
2747             gfc_error ("Coindexed actual argument at %L to allocatable "
2748                        "dummy '%s' requires INTENT(IN)",
2749                        &a->expr->where, f->sym->name);
2750           return 0;
2751         }
2752
2753       /* Fortran 2008, C1237.  */
2754       if (a->expr->expr_type == EXPR_VARIABLE
2755           && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2756           && gfc_is_coindexed (a->expr)
2757           && (a->expr->symtree->n.sym->attr.volatile_
2758               || a->expr->symtree->n.sym->attr.asynchronous))
2759         {
2760           if (where)
2761             gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2762                        "%L requires that dummy '%s' has neither "
2763                        "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2764                        f->sym->name);
2765           return 0;
2766         }
2767
2768       /* Fortran 2008, 12.5.2.4 (no constraint).  */
2769       if (a->expr->expr_type == EXPR_VARIABLE
2770           && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2771           && gfc_is_coindexed (a->expr)
2772           && gfc_has_ultimate_allocatable (a->expr))
2773         {
2774           if (where)
2775             gfc_error ("Coindexed actual argument at %L with allocatable "
2776                        "ultimate component to dummy '%s' requires either VALUE "
2777                        "or INTENT(IN)", &a->expr->where, f->sym->name);
2778           return 0;
2779         }
2780
2781      if (f->sym->ts.type == BT_CLASS
2782            && CLASS_DATA (f->sym)->attr.allocatable
2783            && gfc_is_class_array_ref (a->expr, &full_array)
2784            && !full_array)
2785         {
2786           if (where)
2787             gfc_error ("Actual CLASS array argument for '%s' must be a full "
2788                        "array at %L", f->sym->name, &a->expr->where);
2789           return 0;
2790         }
2791
2792
2793       if (a->expr->expr_type != EXPR_NULL
2794           && compare_allocatable (f->sym, a->expr) == 0)
2795         {
2796           if (where)
2797             gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2798                        f->sym->name, &a->expr->where);
2799           return 0;
2800         }
2801
2802       /* Check intent = OUT/INOUT for definable actual argument.  */
2803       if ((f->sym->attr.intent == INTENT_OUT
2804           || f->sym->attr.intent == INTENT_INOUT))
2805         {
2806           const char* context = (where
2807                                  ? _("actual argument to INTENT = OUT/INOUT")
2808                                  : NULL);
2809
2810           if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2811                 && CLASS_DATA (f->sym)->attr.class_pointer)
2812                || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2813               && !gfc_check_vardef_context (a->expr, true, false, false, context))
2814             return 0;
2815           if (!gfc_check_vardef_context (a->expr, false, false, false, context))
2816             return 0;
2817         }
2818
2819       if ((f->sym->attr.intent == INTENT_OUT
2820            || f->sym->attr.intent == INTENT_INOUT
2821            || f->sym->attr.volatile_
2822            || f->sym->attr.asynchronous)
2823           && gfc_has_vector_subscript (a->expr))
2824         {
2825           if (where)
2826             gfc_error ("Array-section actual argument with vector "
2827                        "subscripts at %L is incompatible with INTENT(OUT), "
2828                        "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2829                        "of the dummy argument '%s'",
2830                        &a->expr->where, f->sym->name);
2831           return 0;
2832         }
2833
2834       /* C1232 (R1221) For an actual argument which is an array section or
2835          an assumed-shape array, the dummy argument shall be an assumed-
2836          shape array, if the dummy argument has the VOLATILE attribute.  */
2837
2838       if (f->sym->attr.volatile_
2839           && a->expr->symtree->n.sym->as
2840           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2841           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2842         {
2843           if (where)
2844             gfc_error ("Assumed-shape actual argument at %L is "
2845                        "incompatible with the non-assumed-shape "
2846                        "dummy argument '%s' due to VOLATILE attribute",
2847                        &a->expr->where,f->sym->name);
2848           return 0;
2849         }
2850
2851       if (f->sym->attr.volatile_
2852           && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2853           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2854         {
2855           if (where)
2856             gfc_error ("Array-section actual argument at %L is "
2857                        "incompatible with the non-assumed-shape "
2858                        "dummy argument '%s' due to VOLATILE attribute",
2859                        &a->expr->where,f->sym->name);
2860           return 0;
2861         }
2862
2863       /* C1233 (R1221) For an actual argument which is a pointer array, the
2864          dummy argument shall be an assumed-shape or pointer array, if the
2865          dummy argument has the VOLATILE attribute.  */
2866
2867       if (f->sym->attr.volatile_
2868           && a->expr->symtree->n.sym->attr.pointer
2869           && a->expr->symtree->n.sym->as
2870           && !(f->sym->as
2871                && (f->sym->as->type == AS_ASSUMED_SHAPE
2872                    || f->sym->attr.pointer)))
2873         {
2874           if (where)
2875             gfc_error ("Pointer-array actual argument at %L requires "
2876                        "an assumed-shape or pointer-array dummy "
2877                        "argument '%s' due to VOLATILE attribute",
2878                        &a->expr->where,f->sym->name);
2879           return 0;
2880         }
2881
2882     match:
2883       if (a == actual)
2884         na = i;
2885
2886       new_arg[i++] = a;
2887     }
2888
2889   /* Make sure missing actual arguments are optional.  */
2890   i = 0;
2891   for (f = formal; f; f = f->next, i++)
2892     {
2893       if (new_arg[i] != NULL)
2894         continue;
2895       if (f->sym == NULL)
2896         {
2897           if (where)
2898             gfc_error ("Missing alternate return spec in subroutine call "
2899                        "at %L", where);
2900           return 0;
2901         }
2902       if (!f->sym->attr.optional)
2903         {
2904           if (where)
2905             gfc_error ("Missing actual argument for argument '%s' at %L",
2906                        f->sym->name, where);
2907           return 0;
2908         }
2909     }
2910
2911   /* The argument lists are compatible.  We now relink a new actual
2912      argument list with null arguments in the right places.  The head
2913      of the list remains the head.  */
2914   for (i = 0; i < n; i++)
2915     if (new_arg[i] == NULL)
2916       new_arg[i] = gfc_get_actual_arglist ();
2917
2918   if (na != 0)
2919     {
2920       temp = *new_arg[0];
2921       *new_arg[0] = *actual;
2922       *actual = temp;
2923
2924       a = new_arg[0];
2925       new_arg[0] = new_arg[na];
2926       new_arg[na] = a;
2927     }
2928
2929   for (i = 0; i < n - 1; i++)
2930     new_arg[i]->next = new_arg[i + 1];
2931
2932   new_arg[i]->next = NULL;
2933
2934   if (*ap == NULL && n > 0)
2935     *ap = new_arg[0];
2936
2937   /* Note the types of omitted optional arguments.  */
2938   for (a = *ap, f = formal; a; a = a->next, f = f->next)
2939     if (a->expr == NULL && a->label == NULL)
2940       a->missing_arg_type = f->sym->ts.type;
2941
2942   return 1;
2943 }
2944
2945
2946 typedef struct
2947 {
2948   gfc_formal_arglist *f;
2949   gfc_actual_arglist *a;
2950 }
2951 argpair;
2952
2953 /* qsort comparison function for argument pairs, with the following
2954    order:
2955     - p->a->expr == NULL
2956     - p->a->expr->expr_type != EXPR_VARIABLE
2957     - growing p->a->expr->symbol.  */
2958
2959 static int
2960 pair_cmp (const void *p1, const void *p2)
2961 {
2962   const gfc_actual_arglist *a1, *a2;
2963
2964   /* *p1 and *p2 are elements of the to-be-sorted array.  */
2965   a1 = ((const argpair *) p1)->a;
2966   a2 = ((const argpair *) p2)->a;
2967   if (!a1->expr)
2968     {
2969       if (!a2->expr)
2970         return 0;
2971       return -1;
2972     }
2973   if (!a2->expr)
2974     return 1;
2975   if (a1->expr->expr_type != EXPR_VARIABLE)
2976     {
2977       if (a2->expr->expr_type != EXPR_VARIABLE)
2978         return 0;
2979       return -1;
2980     }
2981   if (a2->expr->expr_type != EXPR_VARIABLE)
2982     return 1;
2983   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2984 }
2985
2986
2987 /* Given two expressions from some actual arguments, test whether they
2988    refer to the same expression. The analysis is conservative.
2989    Returning false will produce no warning.  */
2990
2991 static bool
2992 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2993 {
2994   const gfc_ref *r1, *r2;
2995
2996   if (!e1 || !e2
2997       || e1->expr_type != EXPR_VARIABLE
2998       || e2->expr_type != EXPR_VARIABLE
2999       || e1->symtree->n.sym != e2->symtree->n.sym)
3000     return false;
3001
3002   /* TODO: improve comparison, see expr.c:show_ref().  */
3003   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
3004     {
3005       if (r1->type != r2->type)
3006         return false;
3007       switch (r1->type)
3008         {
3009         case REF_ARRAY:
3010           if (r1->u.ar.type != r2->u.ar.type)
3011             return false;
3012           /* TODO: At the moment, consider only full arrays;
3013              we could do better.  */
3014           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
3015             return false;
3016           break;
3017
3018         case REF_COMPONENT:
3019           if (r1->u.c.component != r2->u.c.component)
3020             return false;
3021           break;
3022
3023         case REF_SUBSTRING:
3024           return false;
3025
3026         default:
3027           gfc_internal_error ("compare_actual_expr(): Bad component code");
3028         }
3029     }
3030   if (!r1 && !r2)
3031     return true;
3032   return false;
3033 }
3034
3035
3036 /* Given formal and actual argument lists that correspond to one
3037    another, check that identical actual arguments aren't not
3038    associated with some incompatible INTENTs.  */
3039
3040 static bool
3041 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
3042 {
3043   sym_intent f1_intent, f2_intent;
3044   gfc_formal_arglist *f1;
3045   gfc_actual_arglist *a1;
3046   size_t n, i, j;
3047   argpair *p;
3048   bool t = true;
3049
3050   n = 0;
3051   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
3052     {
3053       if (f1 == NULL && a1 == NULL)
3054         break;
3055       if (f1 == NULL || a1 == NULL)
3056         gfc_internal_error ("check_some_aliasing(): List mismatch");
3057       n++;
3058     }
3059   if (n == 0)
3060     return t;
3061   p = XALLOCAVEC (argpair, n);
3062
3063   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
3064     {
3065       p[i].f = f1;
3066       p[i].a = a1;
3067     }
3068
3069   qsort (p, n, sizeof (argpair), pair_cmp);
3070
3071   for (i = 0; i < n; i++)
3072     {
3073       if (!p[i].a->expr
3074           || p[i].a->expr->expr_type != EXPR_VARIABLE
3075           || p[i].a->expr->ts.type == BT_PROCEDURE)
3076         continue;
3077       f1_intent = p[i].f->sym->attr.intent;
3078       for (j = i + 1; j < n; j++)
3079         {
3080           /* Expected order after the sort.  */
3081           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
3082             gfc_internal_error ("check_some_aliasing(): corrupted data");
3083
3084           /* Are the expression the same?  */
3085           if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
3086             break;
3087           f2_intent = p[j].f->sym->attr.intent;
3088           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
3089               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
3090               || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
3091             {
3092               gfc_warning ("Same actual argument associated with INTENT(%s) "
3093                            "argument '%s' and INTENT(%s) argument '%s' at %L",
3094                            gfc_intent_string (f1_intent), p[i].f->sym->name,
3095                            gfc_intent_string (f2_intent), p[j].f->sym->name,
3096                            &p[i].a->expr->where);
3097               t = false;
3098             }
3099         }
3100     }
3101
3102   return t;
3103 }
3104
3105
3106 /* Given formal and actual argument lists that correspond to one
3107    another, check that they are compatible in the sense that intents
3108    are not mismatched.  */
3109
3110 static bool
3111 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
3112 {
3113   sym_intent f_intent;
3114
3115   for (;; f = f->next, a = a->next)
3116     {
3117       if (f == NULL && a == NULL)
3118         break;
3119       if (f == NULL || a == NULL)
3120         gfc_internal_error ("check_intents(): List mismatch");
3121
3122       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
3123         continue;
3124
3125       f_intent = f->sym->attr.intent;
3126
3127       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
3128         {
3129           if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3130                && CLASS_DATA (f->sym)->attr.class_pointer)
3131               || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3132             {
3133               gfc_error ("Procedure argument at %L is local to a PURE "
3134                          "procedure and has the POINTER attribute",
3135                          &a->expr->where);
3136               return false;
3137             }
3138         }
3139
3140        /* Fortran 2008, C1283.  */
3141        if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
3142         {
3143           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
3144             {
3145               gfc_error ("Coindexed actual argument at %L in PURE procedure "
3146                          "is passed to an INTENT(%s) argument",
3147                          &a->expr->where, gfc_intent_string (f_intent));
3148               return false;
3149             }
3150
3151           if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3152                && CLASS_DATA (f->sym)->attr.class_pointer)
3153               || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3154             {
3155               gfc_error ("Coindexed actual argument at %L in PURE procedure "
3156                          "is passed to a POINTER dummy argument",
3157                          &a->expr->where);
3158               return false;
3159             }
3160         }
3161
3162        /* F2008, Section 12.5.2.4.  */
3163        if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3164            && gfc_is_coindexed (a->expr))
3165          {
3166            gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3167                       "polymorphic dummy argument '%s'",
3168                          &a->expr->where, f->sym->name);
3169            return false;
3170          }
3171     }
3172
3173   return true;
3174 }
3175
3176
3177 /* Check how a procedure is used against its interface.  If all goes
3178    well, the actual argument list will also end up being properly
3179    sorted.  */
3180
3181 bool
3182 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3183 {
3184   gfc_formal_arglist *dummy_args;
3185
3186   /* Warn about calls with an implicit interface.  Special case
3187      for calling a ISO_C_BINDING because c_loc and c_funloc
3188      are pseudo-unknown.  Additionally, warn about procedures not
3189      explicitly declared at all if requested.  */
3190   if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
3191     {
3192       if (gfc_option.warn_implicit_interface)
3193         gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3194                      sym->name, where);
3195       else if (gfc_option.warn_implicit_procedure
3196                && sym->attr.proc == PROC_UNKNOWN)
3197         gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3198                      sym->name, where);
3199     }
3200
3201   if (sym->attr.if_source == IFSRC_UNKNOWN)
3202     {
3203       gfc_actual_arglist *a;
3204
3205       if (sym->attr.pointer)
3206         {
3207           gfc_error("The pointer object '%s' at %L must have an explicit "
3208                     "function interface or be declared as array",
3209                     sym->name, where);
3210           return false;
3211         }
3212
3213       if (sym->attr.allocatable && !sym->attr.external)
3214         {
3215           gfc_error("The allocatable object '%s' at %L must have an explicit "
3216                     "function interface or be declared as array",
3217                     sym->name, where);
3218           return false;
3219         }
3220
3221       if (sym->attr.allocatable)
3222         {
3223           gfc_error("Allocatable function '%s' at %L must have an explicit "
3224                     "function interface", sym->name, where);
3225           return false;
3226         }
3227
3228       for (a = *ap; a; a = a->next)
3229         {
3230           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
3231           if (a->name != NULL && a->name[0] != '%')
3232             {
3233               gfc_error("Keyword argument requires explicit interface "
3234                         "for procedure '%s' at %L", sym->name, &a->expr->where);
3235               break;
3236             }
3237
3238           /* TS 29113, 6.2.  */
3239           if (a->expr && a->expr->ts.type == BT_ASSUMED
3240               && sym->intmod_sym_id != ISOCBINDING_LOC)
3241             {
3242               gfc_error ("Assumed-type argument %s at %L requires an explicit "
3243                          "interface", a->expr->symtree->n.sym->name,
3244                          &a->expr->where);
3245               break;
3246             }
3247
3248           /* F2008, C1303 and C1304.  */
3249           if (a->expr
3250               && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3251               && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3252                    && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3253                   || gfc_expr_attr (a->expr).lock_comp))
3254             {
3255               gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3256                         "component at %L requires an explicit interface for "
3257                         "procedure '%s'", &a->expr->where, sym->name);
3258               break;
3259             }
3260
3261           if (a->expr && a->expr->expr_type == EXPR_NULL
3262               && a->expr->ts.type == BT_UNKNOWN)
3263             {
3264               gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3265               return false;
3266             }
3267
3268           /* TS 29113, C407b.  */
3269           if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3270               && symbol_rank (a->expr->symtree->n.sym) == -1)
3271             {
3272               gfc_error ("Assumed-rank argument requires an explicit interface "
3273                          "at %L", &a->expr->where);
3274               return false;
3275             }
3276         }
3277
3278       return true;
3279     }
3280
3281   dummy_args = gfc_sym_get_dummy_args (sym);
3282
3283   if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
3284     return false;
3285
3286   if (!check_intents (dummy_args, *ap))
3287     return false;
3288
3289   if (gfc_option.warn_aliasing)
3290     check_some_aliasing (dummy_args, *ap);
3291
3292   return true;
3293 }
3294
3295
3296 /* Check how a procedure pointer component is used against its interface.
3297    If all goes well, the actual argument list will also end up being properly
3298    sorted. Completely analogous to gfc_procedure_use.  */
3299
3300 void
3301 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3302 {
3303   /* Warn about calls with an implicit interface.  Special case
3304      for calling a ISO_C_BINDING because c_loc and c_funloc
3305      are pseudo-unknown.  */
3306   if (gfc_option.warn_implicit_interface
3307       && comp->attr.if_source == IFSRC_UNKNOWN
3308       && !comp->attr.is_iso_c)
3309     gfc_warning ("Procedure pointer component '%s' called with an implicit "
3310                  "interface at %L", comp->name, where);
3311
3312   if (comp->attr.if_source == IFSRC_UNKNOWN)
3313     {
3314       gfc_actual_arglist *a;
3315       for (a = *ap; a; a = a->next)
3316         {
3317           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
3318           if (a->name != NULL && a->name[0] != '%')
3319             {
3320               gfc_error("Keyword argument requires explicit interface "
3321                         "for procedure pointer component '%s' at %L",
3322                         comp->name, &a->expr->where);
3323               break;
3324             }
3325         }
3326
3327       return;
3328     }
3329
3330   if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
3331                               comp->attr.elemental, where))
3332     return;
3333
3334   check_intents (comp->ts.interface->formal, *ap);
3335   if (gfc_option.warn_aliasing)
3336     check_some_aliasing (comp->ts.interface->formal, *ap);
3337 }
3338
3339
3340 /* Try if an actual argument list matches the formal list of a symbol,
3341    respecting the symbol's attributes like ELEMENTAL.  This is used for
3342    GENERIC resolution.  */
3343
3344 bool
3345 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3346 {
3347   gfc_formal_arglist *dummy_args;
3348   bool r;
3349
3350   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
3351
3352   dummy_args = gfc_sym_get_dummy_args (sym);
3353
3354   r = !sym->attr.elemental;
3355   if (compare_actual_formal (args, dummy_args, r, !r, NULL))
3356     {
3357       check_intents (dummy_args, *args);
3358       if (gfc_option.warn_aliasing)
3359         check_some_aliasing (dummy_args, *args);
3360       return true;
3361     }
3362
3363   return false;
3364 }
3365
3366
3367 /* Given an interface pointer and an actual argument list, search for
3368    a formal argument list that matches the actual.  If found, returns
3369    a pointer to the symbol of the correct interface.  Returns NULL if
3370    not found.  */
3371
3372 gfc_symbol *
3373 gfc_search_interface (gfc_interface *intr, int sub_flag,
3374                       gfc_actual_arglist **ap)
3375 {
3376   gfc_symbol *elem_sym = NULL;
3377   gfc_symbol *null_sym = NULL;
3378   locus null_expr_loc;
3379   gfc_actual_arglist *a;
3380   bool has_null_arg = false;
3381
3382   for (a = *ap; a; a = a->next)
3383     if (a->expr && a->expr->expr_type == EXPR_NULL
3384         && a->expr->ts.type == BT_UNKNOWN)
3385       {
3386         has_null_arg = true;
3387         null_expr_loc = a->expr->where;
3388         break;
3389       }
3390
3391   for (; intr; intr = intr->next)
3392     {
3393       if (intr->sym->attr.flavor == FL_DERIVED)
3394         continue;
3395       if (sub_flag && intr->sym->attr.function)
3396         continue;
3397       if (!sub_flag && intr->sym->attr.subroutine)
3398         continue;
3399
3400       if (gfc_arglist_matches_symbol (ap, intr->sym))
3401         {
3402           if (has_null_arg && null_sym)
3403             {
3404               gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3405                          "between specific functions %s and %s",
3406                          &null_expr_loc, null_sym->name, intr->sym->name);
3407               return NULL;
3408             }
3409           else if (has_null_arg)
3410             {
3411               null_sym = intr->sym;
3412               continue;
3413             }
3414
3415           /* Satisfy 12.4.4.1 such that an elemental match has lower
3416              weight than a non-elemental match.  */
3417           if (intr->sym->attr.elemental)
3418             {
3419               elem_sym = intr->sym;
3420               continue;
3421             }
3422           return intr->sym;
3423         }
3424     }
3425
3426   if (null_sym)
3427     return null_sym;
3428
3429   return elem_sym ? elem_sym : NULL;
3430 }
3431
3432
3433 /* Do a brute force recursive search for a symbol.  */
3434
3435 static gfc_symtree *
3436 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3437 {
3438   gfc_symtree * st;
3439
3440   if (root->n.sym == sym)
3441     return root;
3442
3443   st = NULL;
3444   if (root->left)
3445     st = find_symtree0 (root->left, sym);
3446   if (root->right && ! st)
3447     st = find_symtree0 (root->right, sym);
3448   return st;
3449 }
3450
3451
3452 /* Find a symtree for a symbol.  */
3453
3454 gfc_symtree *
3455 gfc_find_sym_in_symtree (gfc_symbol *sym)
3456 {
3457   gfc_symtree *st;
3458   gfc_namespace *ns;
3459
3460   /* First try to find it by name.  */
3461   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3462   if (st && st->n.sym == sym)
3463     return st;
3464
3465   /* If it's been renamed, resort to a brute-force search.  */
3466   /* TODO: avoid having to do this search.  If the symbol doesn't exist
3467      in the symtree for the current namespace, it should probably be added.  */
3468   for (ns = gfc_current_ns; ns; ns = ns->parent)
3469     {
3470       st = find_symtree0 (ns->sym_root, sym);
3471       if (st)
3472         return st;
3473     }
3474   gfc_internal_error ("Unable to find symbol %s", sym->name);
3475   /* Not reached.  */
3476 }
3477
3478
3479 /* See if the arglist to an operator-call contains a derived-type argument
3480    with a matching type-bound operator.  If so, return the matching specific
3481    procedure defined as operator-target as well as the base-object to use
3482    (which is the found derived-type argument with operator).  The generic
3483    name, if any, is transmitted to the final expression via 'gname'.  */
3484
3485 static gfc_typebound_proc*
3486 matching_typebound_op (gfc_expr** tb_base,
3487                        gfc_actual_arglist* args,
3488                        gfc_intrinsic_op op, const char* uop,
3489                        const char ** gname)
3490 {
3491   gfc_actual_arglist* base;
3492
3493   for (base = args; base; base = base->next)
3494     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3495       {
3496         gfc_typebound_proc* tb;
3497         gfc_symbol* derived;
3498         bool result;
3499
3500         while (base->expr->expr_type == EXPR_OP
3501                && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3502           base->expr = base->expr->value.op.op1;
3503
3504         if (base->expr->ts.type == BT_CLASS)
3505           {
3506             if (CLASS_DATA (base->expr) == NULL
3507                 || !gfc_expr_attr (base->expr).class_ok)
3508               continue;
3509             derived = CLASS_DATA (base->expr)->ts.u.derived;
3510           }
3511         else
3512           derived = base->expr->ts.u.derived;
3513
3514         if (op == INTRINSIC_USER)
3515           {
3516             gfc_symtree* tb_uop;
3517
3518             gcc_assert (uop);
3519             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3520                                                  false, NULL);
3521
3522             if (tb_uop)
3523               tb = tb_uop->n.tb;
3524             else
3525               tb = NULL;
3526           }
3527         else
3528           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3529                                                 false, NULL);
3530
3531         /* This means we hit a PRIVATE operator which is use-associated and
3532            should thus not be seen.  */
3533         if (!result)
3534           tb = NULL;
3535
3536         /* Look through the super-type hierarchy for a matching specific
3537            binding.  */
3538         for (; tb; tb = tb->overridden)
3539           {
3540             gfc_tbp_generic* g;
3541
3542             gcc_assert (tb->is_generic);
3543             for (g = tb->u.generic; g; g = g->next)
3544               {
3545                 gfc_symbol* target;
3546                 gfc_actual_arglist* argcopy;
3547                 bool matches;
3548
3549                 gcc_assert (g->specific);
3550                 if (g->specific->error)
3551                   continue;
3552
3553                 target = g->specific->u.specific->n.sym;
3554
3555                 /* Check if this arglist matches the formal.  */
3556                 argcopy = gfc_copy_actual_arglist (args);
3557                 matches = gfc_arglist_matches_symbol (&argcopy, target);
3558                 gfc_free_actual_arglist (argcopy);
3559
3560                 /* Return if we found a match.  */
3561                 if (matches)
3562                   {
3563                     *tb_base = base->expr;
3564                     *gname = g->specific_st->name;
3565                     return g->specific;
3566                   }
3567               }
3568           }
3569       }
3570
3571   return NULL;
3572 }
3573
3574
3575 /* For the 'actual arglist' of an operator call and a specific typebound
3576    procedure that has been found the target of a type-bound operator, build the
3577    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
3578    type-bound procedures rather than resolving type-bound operators 'directly'
3579    so that we can reuse the existing logic.  */
3580
3581 static void
3582 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3583                              gfc_expr* base, gfc_typebound_proc* target,
3584                              const char *gname)
3585 {
3586   e->expr_type = EXPR_COMPCALL;
3587   e->value.compcall.tbp = target;
3588   e->value.compcall.name = gname ? gname : "$op";
3589   e->value.compcall.actual = actual;
3590   e->value.compcall.base_object = base;
3591   e->value.compcall.ignore_pass = 1;
3592   e->value.compcall.assign = 0;
3593   if (e->ts.type == BT_UNKNOWN
3594         && target->function)
3595     {
3596       if (target->is_generic)
3597         e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3598       else
3599         e->ts = target->u.specific->n.sym->ts;
3600     }
3601 }
3602
3603
3604 /* This subroutine is called when an expression is being resolved.
3605    The expression node in question is either a user defined operator
3606    or an intrinsic operator with arguments that aren't compatible
3607    with the operator.  This subroutine builds an actual argument list
3608    corresponding to the operands, then searches for a compatible
3609    interface.  If one is found, the expression node is replaced with
3610    the appropriate function call. We use the 'match' enum to specify
3611    whether a replacement has been made or not, or if an error occurred.  */
3612
3613 match
3614 gfc_extend_expr (gfc_expr *e)
3615 {
3616   gfc_actual_arglist *actual;
3617   gfc_symbol *sym;
3618   gfc_namespace *ns;
3619   gfc_user_op *uop;
3620   gfc_intrinsic_op i;
3621   const char *gname;
3622
3623   sym = NULL;
3624
3625   actual = gfc_get_actual_arglist ();
3626   actual->expr = e->value.op.op1;
3627
3628   gname = NULL;
3629
3630   if (e->value.op.op2 != NULL)
3631     {
3632       actual->next = gfc_get_actual_arglist ();
3633       actual->next->expr = e->value.op.op2;
3634     }
3635
3636   i = fold_unary_intrinsic (e->value.op.op);
3637
3638   if (i == INTRINSIC_USER)
3639     {
3640       for (ns = gfc_current_ns; ns; ns = ns->parent)
3641         {
3642           uop = gfc_find_uop (e->value.op.uop->name, ns);
3643           if (uop == NULL)
3644             continue;
3645
3646           sym = gfc_search_interface (uop->op, 0, &actual);
3647           if (sym != NULL)
3648             break;
3649         }
3650     }
3651   else
3652     {
3653       for (ns = gfc_current_ns; ns; ns = ns->parent)
3654         {
3655           /* Due to the distinction between '==' and '.eq.' and friends, one has
3656              to check if either is defined.  */
3657           switch (i)
3658             {
3659 #define CHECK_OS_COMPARISON(comp) \
3660   case INTRINSIC_##comp: \
3661   case INTRINSIC_##comp##_OS: \
3662     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3663     if (!sym) \
3664       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3665     break;
3666               CHECK_OS_COMPARISON(EQ)
3667               CHECK_OS_COMPARISON(NE)
3668               CHECK_OS_COMPARISON(GT)
3669               CHECK_OS_COMPARISON(GE)
3670               CHECK_OS_COMPARISON(LT)
3671               CHECK_OS_COMPARISON(LE)
3672 #undef CHECK_OS_COMPARISON
3673
3674               default:
3675                 sym = gfc_search_interface (ns->op[i], 0, &actual);
3676             }
3677
3678           if (sym != NULL)
3679             break;
3680         }
3681     }
3682
3683   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3684      found rather than just taking the first one and not checking further.  */
3685
3686   if (sym == NULL)
3687     {
3688       gfc_typebound_proc* tbo;
3689       gfc_expr* tb_base;
3690
3691       /* See if we find a matching type-bound operator.  */
3692       if (i == INTRINSIC_USER)
3693         tbo = matching_typebound_op (&tb_base, actual,
3694                                      i, e->value.op.uop->name, &gname);
3695       else
3696         switch (i)
3697           {
3698 #define CHECK_OS_COMPARISON(comp) \
3699   case INTRINSIC_##comp: \
3700   case INTRINSIC_##comp##_OS: \
3701     tbo = matching_typebound_op (&tb_base, actual, \
3702                                  INTRINSIC_##comp, NULL, &gname); \
3703     if (!tbo) \
3704       tbo = matching_typebound_op (&tb_base, actual, \
3705                                    INTRINSIC_##comp##_OS, NULL, &gname); \
3706     break;
3707             CHECK_OS_COMPARISON(EQ)
3708             CHECK_OS_COMPARISON(NE)
3709             CHECK_OS_COMPARISON(GT)
3710             CHECK_OS_COMPARISON(GE)
3711             CHECK_OS_COMPARISON(LT)
3712             CHECK_OS_COMPARISON(LE)
3713 #undef CHECK_OS_COMPARISON
3714
3715             default:
3716               tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3717               break;
3718           }
3719
3720       /* If there is a matching typebound-operator, replace the expression with
3721          a call to it and succeed.  */
3722       if (tbo)
3723         {
3724           bool result;
3725
3726           gcc_assert (tb_base);
3727           build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3728
3729           result = gfc_resolve_expr (e);
3730           if (!result)
3731             return MATCH_ERROR;
3732
3733           return MATCH_YES;
3734         }
3735
3736       /* Don't use gfc_free_actual_arglist().  */
3737       free (actual->next);
3738       free (actual);
3739
3740       return MATCH_NO;
3741     }
3742
3743   /* Change the expression node to a function call.  */
3744   e->expr_type = EXPR_FUNCTION;
3745   e->symtree = gfc_find_sym_in_symtree (sym);
3746   e->value.function.actual = actual;
3747   e->value.function.esym = NULL;
3748   e->value.function.isym = NULL;
3749   e->value.function.name = NULL;
3750   e->user_operator = 1;
3751
3752   if (!gfc_resolve_expr (e))
3753     return MATCH_ERROR;
3754
3755   return MATCH_YES;
3756 }
3757
3758
3759 /* Tries to replace an assignment code node with a subroutine call to the
3760    subroutine associated with the assignment operator. Return true if the node
3761    was replaced. On false, no error is generated.  */
3762
3763 bool
3764 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3765 {
3766   gfc_actual_arglist *actual;
3767   gfc_expr *lhs, *rhs, *tb_base;
3768   gfc_symbol *sym = NULL;
3769   const char *gname = NULL;
3770   gfc_typebound_proc* tbo;
3771
3772   lhs = c->expr1;
3773   rhs = c->expr2;
3774
3775   /* Don't allow an intrinsic assignment to be replaced.  */
3776   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3777       && (rhs->rank == 0 || rhs->rank == lhs->rank)
3778       && (lhs->ts.type == rhs->ts.type
3779           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3780     return false;
3781
3782   actual = gfc_get_actual_arglist ();
3783   actual->expr = lhs;
3784
3785   actual->next = gfc_get_actual_arglist ();
3786   actual->next->expr = rhs;
3787
3788   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
3789
3790   /* See if we find a matching type-bound assignment.  */
3791   tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
3792                                NULL, &gname);
3793
3794   if (tbo)
3795     {
3796       /* Success: Replace the expression with a type-bound call.  */
3797       gcc_assert (tb_base);
3798       c->expr1 = gfc_get_expr ();
3799       build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3800       c->expr1->value.compcall.assign = 1;
3801       c->expr1->where = c->loc;
3802       c->expr2 = NULL;
3803       c->op = EXEC_COMPCALL;
3804       return true;
3805     }
3806
3807   /* See if we find an 'ordinary' (non-typebound) assignment procedure.  */
3808   for (; ns; ns = ns->parent)
3809     {
3810       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3811       if (sym != NULL)
3812         break;
3813     }
3814
3815   if (sym)
3816     {
3817       /* Success: Replace the assignment with the call.  */
3818       c->op = EXEC_ASSIGN_CALL;
3819       c->symtree = gfc_find_sym_in_symtree (sym);
3820       c->expr1 = NULL;
3821       c->expr2 = NULL;
3822       c->ext.actual = actual;
3823       return true;
3824     }
3825
3826   /* Failure: No assignment procedure found.  */
3827   free (actual->next);
3828   free (actual);
3829   return false;
3830 }
3831
3832
3833 /* Make sure that the interface just parsed is not already present in
3834    the given interface list.  Ambiguity isn't checked yet since module
3835    procedures can be present without interfaces.  */
3836
3837 bool
3838 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
3839 {
3840   gfc_interface *ip;
3841
3842   for (ip = base; ip; ip = ip->next)
3843     {
3844       if (ip->sym == new_sym)
3845         {
3846           gfc_error ("Entity '%s' at %L is already present in the interface",
3847                      new_sym->name, &loc);
3848           return false;
3849         }
3850     }
3851
3852   return true;
3853 }
3854
3855
3856 /* Add a symbol to the current interface.  */
3857
3858 bool
3859 gfc_add_interface (gfc_symbol *new_sym)
3860 {
3861   gfc_interface **head, *intr;
3862   gfc_namespace *ns;
3863   gfc_symbol *sym;
3864
3865   switch (current_interface.type)
3866     {
3867     case INTERFACE_NAMELESS:
3868     case INTERFACE_ABSTRACT:
3869       return true;
3870
3871     case INTERFACE_INTRINSIC_OP:
3872       for (ns = current_interface.ns; ns; ns = ns->parent)
3873         switch (current_interface.op)
3874           {
3875             case INTRINSIC_EQ:
3876             case INTRINSIC_EQ_OS:
3877               if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
3878                                             gfc_current_locus)
3879                   || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
3880                                                new_sym, gfc_current_locus))
3881                 return false;
3882               break;
3883
3884             case INTRINSIC_NE:
3885             case INTRINSIC_NE_OS:
3886               if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
3887                                             gfc_current_locus)
3888                   || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
3889                                                new_sym, gfc_current_locus))
3890                 return false;
3891               break;
3892
3893             case INTRINSIC_GT:
3894             case INTRINSIC_GT_OS:
3895               if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
3896                                             new_sym, gfc_current_locus)
3897                   || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
3898                                                new_sym, gfc_current_locus))
3899                 return false;
3900               break;
3901
3902             case INTRINSIC_GE:
3903             case INTRINSIC_GE_OS:
3904               if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
3905                                             new_sym, gfc_current_locus)
3906                   || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
3907                                                new_sym, gfc_current_locus))
3908                 return false;
3909               break;
3910
3911             case INTRINSIC_LT:
3912             case INTRINSIC_LT_OS:
3913               if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
3914                                             new_sym, gfc_current_locus)
3915                   || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
3916                                                new_sym, gfc_current_locus))
3917                 return false;
3918               break;
3919
3920             case INTRINSIC_LE:
3921             case INTRINSIC_LE_OS:
3922               if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
3923                                             new_sym, gfc_current_locus)
3924                   || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
3925                                                new_sym, gfc_current_locus))
3926                 return false;
3927               break;
3928
3929             default:
3930               if (!gfc_check_new_interface (ns->op[current_interface.op],
3931                                             new_sym, gfc_current_locus))
3932                 return false;
3933           }
3934
3935       head = &current_interface.ns->op[current_interface.op];
3936       break;
3937
3938     case INTERFACE_GENERIC:
3939       for (ns = current_interface.ns; ns; ns = ns->parent)
3940         {
3941           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3942           if (sym == NULL)
3943             continue;
3944
3945           if (!gfc_check_new_interface (sym->generic,
3946                                         new_sym, gfc_current_locus))
3947             return false;
3948         }
3949
3950       head = &current_interface.sym->generic;
3951       break;
3952
3953     case INTERFACE_USER_OP:
3954       if (!gfc_check_new_interface (current_interface.uop->op,
3955                                     new_sym, gfc_current_locus))
3956         return false;
3957
3958       head = &current_interface.uop->op;
3959       break;
3960
3961     default:
3962       gfc_internal_error ("gfc_add_interface(): Bad interface type");
3963     }
3964
3965   intr = gfc_get_interface ();
3966   intr->sym = new_sym;
3967   intr->where = gfc_current_locus;
3968
3969   intr->next = *head;
3970   *head = intr;
3971
3972   return true;
3973 }
3974
3975
3976 gfc_interface *
3977 gfc_current_interface_head (void)
3978 {
3979   switch (current_interface.type)
3980     {
3981       case INTERFACE_INTRINSIC_OP:
3982         return current_interface.ns->op[current_interface.op];
3983         break;
3984
3985       case INTERFACE_GENERIC:
3986         return current_interface.sym->generic;
3987         break;
3988
3989       case INTERFACE_USER_OP:
3990         return current_interface.uop->op;
3991         break;
3992
3993       default:
3994         gcc_unreachable ();
3995     }
3996 }
3997
3998
3999 void
4000 gfc_set_current_interface_head (gfc_interface *i)
4001 {
4002   switch (current_interface.type)
4003     {
4004       case INTERFACE_INTRINSIC_OP:
4005         current_interface.ns->op[current_interface.op] = i;
4006         break;
4007
4008       case INTERFACE_GENERIC:
4009         current_interface.sym->generic = i;
4010         break;
4011
4012       case INTERFACE_USER_OP:
4013         current_interface.uop->op = i;
4014         break;
4015
4016       default:
4017         gcc_unreachable ();
4018     }
4019 }
4020
4021
4022 /* Gets rid of a formal argument list.  We do not free symbols.
4023    Symbols are freed when a namespace is freed.  */
4024
4025 void
4026 gfc_free_formal_arglist (gfc_formal_arglist *p)
4027 {
4028   gfc_formal_arglist *q;
4029
4030   for (; p; p = q)
4031     {
4032       q = p->next;
4033       free (p);
4034     }
4035 }
4036
4037
4038 /* Check that it is ok for the type-bound procedure 'proc' to override the
4039    procedure 'old', cf. F08:4.5.7.3.  */
4040
4041 bool
4042 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
4043 {
4044   locus where;
4045   gfc_symbol *proc_target, *old_target;
4046   unsigned proc_pass_arg, old_pass_arg, argpos;
4047   gfc_formal_arglist *proc_formal, *old_formal;
4048   bool check_type;
4049   char err[200];
4050
4051   /* This procedure should only be called for non-GENERIC proc.  */
4052   gcc_assert (!proc->n.tb->is_generic);
4053
4054   /* If the overwritten procedure is GENERIC, this is an error.  */
4055   if (old->n.tb->is_generic)
4056     {
4057       gfc_error ("Can't overwrite GENERIC '%s' at %L",
4058                  old->name, &proc->n.tb->where);
4059       return false;
4060     }
4061
4062   where = proc->n.tb->where;
4063   proc_target = proc->n.tb->u.specific->n.sym;
4064   old_target = old->n.tb->u.specific->n.sym;
4065
4066   /* Check that overridden binding is not NON_OVERRIDABLE.  */
4067   if (old->n.tb->non_overridable)
4068     {
4069       gfc_error ("'%s' at %L overrides a procedure binding declared"
4070                  " NON_OVERRIDABLE", proc->name, &where);
4071       return false;
4072     }
4073
4074   /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
4075   if (!old->n.tb->deferred && proc->n.tb->deferred)
4076     {
4077       gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
4078                  " non-DEFERRED binding", proc->name, &where);
4079       return false;
4080     }
4081
4082   /* If the overridden binding is PURE, the overriding must be, too.  */
4083   if (old_target->attr.pure && !proc_target->attr.pure)
4084     {
4085       gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
4086                  proc->name, &where);
4087       return false;
4088     }
4089
4090   /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
4091      is not, the overriding must not be either.  */
4092   if (old_target->attr.elemental && !proc_target->attr.elemental)
4093     {
4094       gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4095                  " ELEMENTAL", proc->name, &where);
4096       return false;
4097     }
4098   if (!old_target->attr.elemental && proc_target->attr.elemental)
4099     {
4100       gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4101                  " be ELEMENTAL, either", proc->name, &where);
4102       return false;
4103     }
4104
4105   /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4106      SUBROUTINE.  */
4107   if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4108     {
4109       gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4110                  " SUBROUTINE", proc->name, &where);
4111       return false;
4112     }
4113
4114   /* If the overridden binding is a FUNCTION, the overriding must also be a
4115      FUNCTION and have the same characteristics.  */
4116   if (old_target->attr.function)
4117     {
4118       if (!proc_target->attr.function)
4119         {
4120           gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4121                      " FUNCTION", proc->name, &where);
4122           return false;
4123         }
4124
4125       if (!check_result_characteristics (proc_target, old_target, err,
4126                                          sizeof(err)))
4127         {
4128           gfc_error ("Result mismatch for the overriding procedure "
4129                      "'%s' at %L: %s", proc->name, &where, err);
4130           return false;
4131         }
4132     }
4133
4134   /* If the overridden binding is PUBLIC, the overriding one must not be
4135      PRIVATE.  */
4136   if (old->n.tb->access == ACCESS_PUBLIC
4137       && proc->n.tb->access == ACCESS_PRIVATE)
4138     {
4139       gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4140                  " PRIVATE", proc->name, &where);
4141       return false;
4142     }
4143
4144   /* Compare the formal argument lists of both procedures.  This is also abused
4145      to find the position of the passed-object dummy arguments of both
4146      bindings as at least the overridden one might not yet be resolved and we
4147      need those positions in the check below.  */
4148   proc_pass_arg = old_pass_arg = 0;
4149   if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4150     proc_pass_arg = 1;
4151   if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4152     old_pass_arg = 1;
4153   argpos = 1;
4154   proc_formal = gfc_sym_get_dummy_args (proc_target);
4155   old_formal = gfc_sym_get_dummy_args (old_target);
4156   for ( ; proc_formal && old_formal;
4157        proc_formal = proc_formal->next, old_formal = old_formal->next)
4158     {
4159       if (proc->n.tb->pass_arg
4160           && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4161         proc_pass_arg = argpos;
4162       if (old->n.tb->pass_arg
4163           && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4164         old_pass_arg = argpos;
4165
4166       /* Check that the names correspond.  */
4167       if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4168         {
4169           gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4170                      " to match the corresponding argument of the overridden"
4171                      " procedure", proc_formal->sym->name, proc->name, &where,
4172                      old_formal->sym->name);
4173           return false;
4174         }
4175
4176       check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4177       if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4178                                         check_type, err, sizeof(err)))
4179         {
4180           gfc_error ("Argument mismatch for the overriding procedure "
4181                      "'%s' at %L: %s", proc->name, &where, err);
4182           return false;
4183         }
4184
4185       ++argpos;
4186     }
4187   if (proc_formal || old_formal)
4188     {
4189       gfc_error ("'%s' at %L must have the same number of formal arguments as"
4190                  " the overridden procedure", proc->name, &where);
4191       return false;
4192     }
4193
4194   /* If the overridden binding is NOPASS, the overriding one must also be
4195      NOPASS.  */
4196   if (old->n.tb->nopass && !proc->n.tb->nopass)
4197     {
4198       gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4199                  " NOPASS", proc->name, &where);
4200       return false;
4201     }
4202
4203   /* If the overridden binding is PASS(x), the overriding one must also be
4204      PASS and the passed-object dummy arguments must correspond.  */
4205   if (!old->n.tb->nopass)
4206     {
4207       if (proc->n.tb->nopass)
4208         {
4209           gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4210                      " PASS", proc->name, &where);
4211           return false;
4212         }
4213
4214       if (proc_pass_arg != old_pass_arg)
4215         {
4216           gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4217                      " the same position as the passed-object dummy argument of"
4218                      " the overridden procedure", proc->name, &where);
4219           return false;
4220         }
4221     }
4222
4223   return true;
4224 }