gcc/fortran/interface.c

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