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