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   /* Special case for comparing derived types across namespaces.  If the
 400      true names and module names are the same and the module name is
 401      nonnull, then they are equal.  */
 402   if (derived1 != NULL && derived2 != NULL
 403       && strcmp (derived1->name, derived2->name) == 0
 404       && derived1->module != NULL && derived2->module != NULL
 405       && strcmp (derived1->module, derived2->module) == 0)
 406     return 1;
 407
 408   /* Compare type via the rules of the standard.  Both types must have
 409      the SEQUENCE or BIND(C) attribute to be equal.  */
 410
 411   if (strcmp (derived1->name, derived2->name))
 412     return 0;
 413
 414   if (derived1->component_access == ACCESS_PRIVATE
 415       || derived2->component_access == ACCESS_PRIVATE)
 416     return 0;
 417
 418   if (!(derived1->attr.sequence && derived2->attr.sequence)
 419       && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
 420     return 0;
 421
 422   dt1 = derived1->components;
 423   dt2 = derived2->components;
 424
 425   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
 426      simple test can speed things up.  Otherwise, lots of things have to
 427      match.  */
 428   for (;;)
 429     {
 430       if (strcmp (dt1->name, dt2->name) != 0)
 431         return 0;
 432
 433       if (dt1->attr.access != dt2->attr.access)
 434         return 0;
 435
 436       if (dt1->attr.pointer != dt2->attr.pointer)
 437         return 0;
 438
 439       if (dt1->attr.dimension != dt2->attr.dimension)
 440         return 0;
 441
 442      if (dt1->attr.allocatable != dt2->attr.allocatable)
 443         return 0;
 444
 445       if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
 446         return 0;
 447
 448       /* Make sure that link lists do not put this function into an
 449          endless recursive loop!  */
 450       if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 451             && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 452             && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
 453         return 0;
 454
 455       else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 456                 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 457         return 0;
 458
 459       else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 460                 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 461         return 0;
 462
 463       dt1 = dt1->next;
 464       dt2 = dt2->next;
 465
 466       if (dt1 == NULL && dt2 == NULL)
 467         break;
 468       if (dt1 == NULL || dt2 == NULL)
 469         return 0;
 470     }
 471
 472   return 1;
 473 }
 474
 475
 476 /* Compare two typespecs, recursively if necessary.  */
 477
 478 int
 479 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
 480 {
 481   /* See if one of the typespecs is a BT_VOID, which is what is being used
 482      to allow the funcs like c_f_pointer to accept any pointer type.
 483      TODO: Possibly should narrow this to just the one typespec coming in
 484      that is for the formal arg, but oh well.  */
 485   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
 486     return 1;
 487
 488   if (ts1->type != ts2->type
 489       && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
 490           || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
 491     return 0;
 492   if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
 493     return (ts1->kind == ts2->kind);
 494
 495   /* Compare derived types.  */
 496   if (gfc_type_compatible (ts1, ts2))
 497     return 1;
 498
 499   return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
 500 }
 501
 502
 503 /* Given two symbols that are formal arguments, compare their ranks
 504    and types.  Returns nonzero if they have the same rank and type,
 505    zero otherwise.  */
 506
 507 static int
 508 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
 509 {
 510   gfc_array_spec *as1, *as2;
 511   int r1, r2;
 512
 513   as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
 514   as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
 515
 516   r1 = as1 ? as1->rank : 0;
 517   r2 = as2 ? as2->rank : 0;
 518
 519   if (r1 != r2
 520       && (!as1 || as1->type != AS_ASSUMED_RANK)
 521       && (!as2 || as2->type != AS_ASSUMED_RANK))
 522     return 0;                   /* Ranks differ.  */
 523
 524   return gfc_compare_types (&s1->ts, &s2->ts)
 525          || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
 526 }
 527
 528
 529 /* Given two symbols that are formal arguments, compare their types
 530    and rank and their formal interfaces if they are both dummy
 531    procedures.  Returns nonzero if the same, zero if different.  */
 532
 533 static int
 534 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
 535 {
 536   if (s1 == NULL || s2 == NULL)
 537     return s1 == s2 ? 1 : 0;
 538
 539   if (s1 == s2)
 540     return 1;
 541
 542   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
 543     return compare_type_rank (s1, s2);
 544
 545   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
 546     return 0;
 547
 548   /* At this point, both symbols are procedures.  It can happen that
 549      external procedures are compared, where one is identified by usage
 550      to be a function or subroutine but the other is not.  Check TKR
 551      nonetheless for these cases.  */
 552   if (s1->attr.function == 0 && s1->attr.subroutine == 0)
 553     return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
 554
 555   if (s2->attr.function == 0 && s2->attr.subroutine == 0)
 556     return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
 557
 558   /* Now the type of procedure has been identified.  */
 559   if (s1->attr.function != s2->attr.function
 560       || s1->attr.subroutine != s2->attr.subroutine)
 561     return 0;
 562
 563   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
 564     return 0;
 565
 566   /* Originally, gfortran recursed here to check the interfaces of passed
 567      procedures.  This is explicitly not required by the standard.  */
 568   return 1;
 569 }
 570
 571
 572 /* Given a formal argument list and a keyword name, search the list
 573    for that keyword.  Returns the correct symbol node if found, NULL
 574    if not found.  */
 575
 576 static gfc_symbol *
 577 find_keyword_arg (const char *name, gfc_formal_arglist *f)
 578 {
 579   for (; f; f = f->next)
 580     if (strcmp (f->sym->name, name) == 0)
 581       return f->sym;
 582
 583   return NULL;
 584 }
 585
 586
 587 /******** Interface checking subroutines **********/
 588
 589
 590 /* Given an operator interface and the operator, make sure that all
 591    interfaces for that operator are legal.  */
 592
 593 bool
 594 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
 595                               locus opwhere)
 596 {
 597   gfc_formal_arglist *formal;
 598   sym_intent i1, i2;
 599   bt t1, t2;
 600   int args, r1, r2, k1, k2;
 601
 602   gcc_assert (sym);
 603
 604   args = 0;
 605   t1 = t2 = BT_UNKNOWN;
 606   i1 = i2 = INTENT_UNKNOWN;
 607   r1 = r2 = -1;
 608   k1 = k2 = -1;
 609
 610   for (formal = sym->formal; formal; formal = formal->next)
 611     {
 612       gfc_symbol *fsym = formal->sym;
 613       if (fsym == NULL)
 614         {
 615           gfc_error ("Alternate return cannot appear in operator "
 616                      "interface at %L", &sym->declared_at);
 617           return false;
 618         }
 619       if (args == 0)
 620         {
 621           t1 = fsym->ts.type;
 622           i1 = fsym->attr.intent;
 623           r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
 624           k1 = fsym->ts.kind;
 625         }
 626       if (args == 1)
 627         {
 628           t2 = fsym->ts.type;
 629           i2 = fsym->attr.intent;
 630           r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
 631           k2 = fsym->ts.kind;
 632         }
 633       args++;
 634     }
 635
 636   /* Only +, - and .not. can be unary operators.
 637      .not. cannot be a binary operator.  */
 638   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
 639                                 && op != INTRINSIC_MINUS
 640                                 && op != INTRINSIC_NOT)
 641       || (args == 2 && op == INTRINSIC_NOT))
 642     {
 643       gfc_error ("Operator interface at %L has the wrong number of arguments",
 644                  &sym->declared_at);
 645       return false;
 646     }
 647
 648   /* Check that intrinsics are mapped to functions, except
 649      INTRINSIC_ASSIGN which should map to a subroutine.  */
 650   if (op == INTRINSIC_ASSIGN)
 651     {
 652       if (!sym->attr.subroutine)
 653         {
 654           gfc_error ("Assignment operator interface at %L must be "
 655                      "a SUBROUTINE", &sym->declared_at);
 656           return false;
 657         }
 658       if (args != 2)
 659         {
 660           gfc_error ("Assignment operator interface at %L must have "
 661                      "two arguments", &sym->declared_at);
 662           return false;
 663         }
 664
 665       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
 666          - First argument an array with different rank than second,
 667          - First argument is a scalar and second an array,
 668          - Types and kinds do not conform, or
 669          - First argument is of derived type.  */
 670       if (sym->formal->sym->ts.type != BT_DERIVED
 671           && sym->formal->sym->ts.type != BT_CLASS
 672           && (r2 == 0 || r1 == r2)
 673           && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
 674               || (gfc_numeric_ts (&sym->formal->sym->ts)
 675                   && gfc_numeric_ts (&sym->formal->next->sym->ts))))
 676         {
 677           gfc_error ("Assignment operator interface at %L must not redefine "
 678                      "an INTRINSIC type assignment", &sym->declared_at);
 679           return false;
 680         }
 681     }
 682   else
 683     {
 684       if (!sym->attr.function)
 685         {
 686           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
 687                      &sym->declared_at);
 688           return false;
 689         }
 690     }
 691
 692   /* Check intents on operator interfaces.  */
 693   if (op == INTRINSIC_ASSIGN)
 694     {
 695       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
 696         {
 697           gfc_error ("First argument of defined assignment at %L must be "
 698                      "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
 699           return false;
 700         }
 701
 702       if (i2 != INTENT_IN)
 703         {
 704           gfc_error ("Second argument of defined assignment at %L must be "
 705                      "INTENT(IN)", &sym->declared_at);
 706           return false;
 707         }
 708     }
 709   else
 710     {
 711       if (i1 != INTENT_IN)
 712         {
 713           gfc_error ("First argument of operator interface at %L must be "
 714                      "INTENT(IN)", &sym->declared_at);
 715           return false;
 716         }
 717
 718       if (args == 2 && i2 != INTENT_IN)
 719         {
 720           gfc_error ("Second argument of operator interface at %L must be "
 721                      "INTENT(IN)", &sym->declared_at);
 722           return false;
 723         }
 724     }
 725
 726   /* From now on, all we have to do is check that the operator definition
 727      doesn't conflict with an intrinsic operator. The rules for this
 728      game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
 729      as well as 12.3.2.1.1 of Fortran 2003:
 730
 731      "If the operator is an intrinsic-operator (R310), the number of
 732      function arguments shall be consistent with the intrinsic uses of
 733      that operator, and the types, kind type parameters, or ranks of the
 734      dummy arguments shall differ from those required for the intrinsic
 735      operation (7.1.2)."  */
 736
 737 #define IS_NUMERIC_TYPE(t) \
 738   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
 739
 740   /* Unary ops are easy, do them first.  */
 741   if (op == INTRINSIC_NOT)
 742     {
 743       if (t1 == BT_LOGICAL)
 744         goto bad_repl;
 745       else
 746         return true;
 747     }
 748
 749   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
 750     {
 751       if (IS_NUMERIC_TYPE (t1))
 752         goto bad_repl;
 753       else
 754         return true;
 755     }
 756
 757   /* Character intrinsic operators have same character kind, thus
 758      operator definitions with operands of different character kinds
 759      are always safe.  */
 760   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
 761     return true;
 762
 763   /* Intrinsic operators always perform on arguments of same rank,
 764      so different ranks is also always safe.  (rank == 0) is an exception
 765      to that, because all intrinsic operators are elemental.  */
 766   if (r1 != r2 && r1 != 0 && r2 != 0)
 767     return true;
 768
 769   switch (op)
 770   {
 771     case INTRINSIC_EQ:
 772     case INTRINSIC_EQ_OS:
 773     case INTRINSIC_NE:
 774     case INTRINSIC_NE_OS:
 775       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 776         goto bad_repl;
 777       /* Fall through.  */
 778
 779     case INTRINSIC_PLUS:
 780     case INTRINSIC_MINUS:
 781     case INTRINSIC_TIMES:
 782     case INTRINSIC_DIVIDE:
 783     case INTRINSIC_POWER:
 784       if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
 785         goto bad_repl;
 786       break;
 787
 788     case INTRINSIC_GT:
 789     case INTRINSIC_GT_OS:
 790     case INTRINSIC_GE:
 791     case INTRINSIC_GE_OS:
 792     case INTRINSIC_LT:
 793     case INTRINSIC_LT_OS:
 794     case INTRINSIC_LE:
 795     case INTRINSIC_LE_OS:
 796       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 797         goto bad_repl;
 798       if ((t1 == BT_INTEGER || t1 == BT_REAL)
 799           && (t2 == BT_INTEGER || t2 == BT_REAL))
 800         goto bad_repl;
 801       break;
 802
 803     case INTRINSIC_CONCAT:
 804       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 805         goto bad_repl;
 806       break;
 807
 808     case INTRINSIC_AND:
 809     case INTRINSIC_OR:
 810     case INTRINSIC_EQV:
 811     case INTRINSIC_NEQV:
 812       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
 813         goto bad_repl;
 814       break;
 815
 816     default:
 817       break;
 818   }
 819
 820   return true;
 821
 822 #undef IS_NUMERIC_TYPE
 823
 824 bad_repl:
 825   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
 826              &opwhere);
 827   return false;
 828 }
 829
 830
 831 /* Given a pair of formal argument lists, we see if the two lists can
 832    be distinguished by counting the number of nonoptional arguments of
 833    a given type/rank in f1 and seeing if there are less then that
 834    number of those arguments in f2 (including optional arguments).
 835    Since this test is asymmetric, it has to be called twice to make it
 836    symmetric. Returns nonzero if the argument lists are incompatible
 837    by this test. This subroutine implements rule 1 of section F03:16.2.3.
 838    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
 839
 840 static int
 841 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 842                   const char *p1, const char *p2)
 843 {
 844   int rc, ac1, ac2, i, j, k, n1;
 845   gfc_formal_arglist *f;
 846
 847   typedef struct
 848   {
 849     int flag;
 850     gfc_symbol *sym;
 851   }
 852   arginfo;
 853
 854   arginfo *arg;
 855
 856   n1 = 0;
 857
 858   for (f = f1; f; f = f->next)
 859     n1++;
 860
 861   /* Build an array of integers that gives the same integer to
 862      arguments of the same type/rank.  */
 863   arg = XCNEWVEC (arginfo, n1);
 864
 865   f = f1;
 866   for (i = 0; i < n1; i++, f = f->next)
 867     {
 868       arg[i].flag = -1;
 869       arg[i].sym = f->sym;
 870     }
 871
 872   k = 0;
 873
 874   for (i = 0; i < n1; i++)
 875     {
 876       if (arg[i].flag != -1)
 877         continue;
 878
 879       if (arg[i].sym && (arg[i].sym->attr.optional
 880                          || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
 881         continue;               /* Skip OPTIONAL and PASS arguments.  */
 882
 883       arg[i].flag = k;
 884
 885       /* Find other non-optional, non-pass arguments of the same type/rank.  */
 886       for (j = i + 1; j < n1; j++)
 887         if ((arg[j].sym == NULL
 888              || !(arg[j].sym->attr.optional
 889                   || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
 890             && (compare_type_rank_if (arg[i].sym, arg[j].sym)
 891                 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
 892           arg[j].flag = k;
 893
 894       k++;
 895     }
 896
 897   /* Now loop over each distinct type found in f1.  */
 898   k = 0;
 899   rc = 0;
 900
 901   for (i = 0; i < n1; i++)
 902     {
 903       if (arg[i].flag != k)
 904         continue;
 905
 906       ac1 = 1;
 907       for (j = i + 1; j < n1; j++)
 908         if (arg[j].flag == k)
 909           ac1++;
 910
 911       /* Count the number of non-pass arguments in f2 with that type,
 912          including those that are optional.  */
 913       ac2 = 0;
 914
 915       for (f = f2; f; f = f->next)
 916         if ((!p2 || strcmp (f->sym->name, p2) != 0)
 917             && (compare_type_rank_if (arg[i].sym, f->sym)
 918                 || compare_type_rank_if (f->sym, arg[i].sym)))
 919           ac2++;
 920
 921       if (ac1 > ac2)
 922         {
 923           rc = 1;
 924           break;
 925         }
 926
 927       k++;
 928     }
 929
 930   free (arg);
 931
 932   return rc;
 933 }
 934
 935
 936 /* Perform the correspondence test in rule 3 of section F03:16.2.3.
 937    Returns zero if no argument is found that satisfies rule 3, nonzero
 938    otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
 939    (if applicable).
 940
 941    This test is also not symmetric in f1 and f2 and must be called
 942    twice.  This test finds problems caused by sorting the actual
 943    argument list with keywords.  For example:
 944
 945    INTERFACE FOO
 946        SUBROUTINE F1(A, B)
 947            INTEGER :: A ; REAL :: B
 948        END SUBROUTINE F1
 949
 950        SUBROUTINE F2(B, A)
 951            INTEGER :: A ; REAL :: B
 952        END SUBROUTINE F1
 953    END INTERFACE FOO
 954
 955    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
 956
 957 static int
 958 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 959                         const char *p1, const char *p2)
 960 {
 961   gfc_formal_arglist *f2_save, *g;
 962   gfc_symbol *sym;
 963
 964   f2_save = f2;
 965
 966   while (f1)
 967     {
 968       if (f1->sym->attr.optional)
 969         goto next;
 970
 971       if (p1 && strcmp (f1->sym->name, p1) == 0)
 972         f1 = f1->next;
 973       if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
 974         f2 = f2->next;
 975
 976       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
 977                          || compare_type_rank (f2->sym, f1->sym)))
 978         goto next;
 979
 980       /* Now search for a disambiguating keyword argument starting at
 981          the current non-match.  */
 982       for (g = f1; g; g = g->next)
 983         {
 984           if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
 985             continue;
 986
 987           sym = find_keyword_arg (g->sym->name, f2_save);
 988           if (sym == NULL || !compare_type_rank (g->sym, sym))
 989             return 1;
 990         }
 991
 992     next:
 993       if (f1 != NULL)
 994         f1 = f1->next;
 995       if (f2 != NULL)
 996         f2 = f2->next;
 997     }
 998
 999   return 0;
1000 }
1001
1002
1003 /* Check if the characteristics of two dummy arguments match,
1004    cf. F08:12.3.2.  */
1005
1006 static gfc_try
1007 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1008                              bool type_must_agree, char *errmsg, int err_len)
1009 {
1010   /* Check type and rank.  */
1011   if (type_must_agree && !compare_type_rank (s2, s1))
1012     {
1013       snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1014                 s1->name);
1015       return FAILURE;
1016     }
1017
1018   /* Check INTENT.  */
1019   if (s1->attr.intent != s2->attr.intent)
1020     {
1021       snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1022                 s1->name);
1023       return FAILURE;
1024     }
1025
1026   /* Check OPTIONAL attribute.  */
1027   if (s1->attr.optional != s2->attr.optional)
1028     {
1029       snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1030                 s1->name);
1031       return FAILURE;
1032     }
1033
1034   /* Check ALLOCATABLE attribute.  */
1035   if (s1->attr.allocatable != s2->attr.allocatable)
1036     {
1037       snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1038                 s1->name);
1039       return FAILURE;
1040     }
1041
1042   /* Check POINTER attribute.  */
1043   if (s1->attr.pointer != s2->attr.pointer)
1044     {
1045       snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1046                 s1->name);
1047       return FAILURE;
1048     }
1049
1050   /* Check TARGET attribute.  */
1051   if (s1->attr.target != s2->attr.target)
1052     {
1053       snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1054                 s1->name);
1055       return FAILURE;
1056     }
1057
1058   /* FIXME: Do more comprehensive testing of attributes, like e.g.
1059             ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc.  */
1060
1061   /* Check string length.  */
1062   if (s1->ts.type == BT_CHARACTER
1063       && s1->ts.u.cl && s1->ts.u.cl->length
1064       && s2->ts.u.cl && s2->ts.u.cl->length)
1065     {
1066       int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1067                                           s2->ts.u.cl->length);
1068       switch (compval)
1069       {
1070         case -1:
1071         case  1:
1072         case -3:
1073           snprintf (errmsg, err_len, "Character length mismatch "
1074                     "in argument '%s'", s1->name);
1075           return FAILURE;
1076
1077         case -2:
1078           /* FIXME: Implement a warning for this case.
1079           gfc_warning ("Possible character length mismatch in argument '%s'",
1080                        s1->name);*/
1081           break;
1082
1083         case 0:
1084           break;
1085
1086         default:
1087           gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1088                               "%i of gfc_dep_compare_expr", compval);
1089           break;
1090       }
1091     }
1092
1093   /* Check array shape.  */
1094   if (s1->as && s2->as)
1095     {
1096       int i, compval;
1097       gfc_expr *shape1, *shape2;
1098
1099       if (s1->as->type != s2->as->type)
1100         {
1101           snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1102                     s1->name);
1103           return FAILURE;
1104         }
1105
1106       if (s1->as->type == AS_EXPLICIT)
1107         for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1108           {
1109             shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1110                                   gfc_copy_expr (s1->as->lower[i]));
1111             shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1112                                   gfc_copy_expr (s2->as->lower[i]));
1113             compval = gfc_dep_compare_expr (shape1, shape2);
1114             gfc_free_expr (shape1);
1115             gfc_free_expr (shape2);
1116             switch (compval)
1117             {
1118               case -1:
1119               case  1:
1120               case -3:
1121                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1122                           "argument '%s'", i + 1, s1->name);
1123                 return FAILURE;
1124
1125               case -2:
1126                 /* FIXME: Implement a warning for this case.
1127                 gfc_warning ("Possible shape mismatch in argument '%s'",
1128                             s1->name);*/
1129                 break;
1130
1131               case 0:
1132                 break;
1133
1134               default:
1135                 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1136                                     "result %i of gfc_dep_compare_expr",
1137                                     compval);
1138                 break;
1139             }
1140           }
1141     }
1142
1143   return SUCCESS;
1144 }
1145
1146
1147 /* Check if the characteristics of two function results match,
1148    cf. F08:12.3.3.  */
1149
1150 static gfc_try
1151 check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1152                               char *errmsg, int err_len)
1153 {
1154   gfc_symbol *r1, *r2;
1155
1156   r1 = s1->result ? s1->result : s1;
1157   r2 = s2->result ? s2->result : s2;
1158
1159   if (r1->ts.type == BT_UNKNOWN)
1160     return SUCCESS;
1161
1162   /* Check type and rank.  */
1163   if (!compare_type_rank (r1, r2))
1164     {
1165       snprintf (errmsg, err_len, "Type/rank mismatch in function result");
1166       return FAILURE;
1167     }
1168
1169   /* Check ALLOCATABLE attribute.  */
1170   if (r1->attr.allocatable != r2->attr.allocatable)
1171     {
1172       snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1173                 "function result");
1174       return FAILURE;
1175     }
1176
1177   /* Check POINTER attribute.  */
1178   if (r1->attr.pointer != r2->attr.pointer)
1179     {
1180       snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1181                 "function result");
1182       return FAILURE;
1183     }
1184
1185   /* Check CONTIGUOUS attribute.  */
1186   if (r1->attr.contiguous != r2->attr.contiguous)
1187     {
1188       snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1189                 "function result");
1190       return FAILURE;
1191     }
1192
1193   /* Check PROCEDURE POINTER attribute.  */
1194   if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1195     {
1196       snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1197                 "function result");
1198       return FAILURE;
1199     }
1200
1201   /* Check string length.  */
1202   if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1203     {
1204       if (r1->ts.deferred != r2->ts.deferred)
1205         {
1206           snprintf (errmsg, err_len, "Character length mismatch "
1207                     "in function result");
1208           return FAILURE;
1209         }
1210
1211       if (r1->ts.u.cl->length)
1212         {
1213           int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1214                                               r2->ts.u.cl->length);
1215           switch (compval)
1216           {
1217             case -1:
1218             case  1:
1219             case -3:
1220               snprintf (errmsg, err_len, "Character length mismatch "
1221                         "in function result");
1222               return FAILURE;
1223
1224             case -2:
1225               /* FIXME: Implement a warning for this case.
1226               snprintf (errmsg, err_len, "Possible character length mismatch "
1227                         "in function result");*/
1228               break;
1229
1230             case 0:
1231               break;
1232
1233             default:
1234               gfc_internal_error ("check_result_characteristics (1): Unexpected "
1235                                   "result %i of gfc_dep_compare_expr", compval);
1236               break;
1237           }
1238         }
1239     }
1240
1241   /* Check array shape.  */
1242   if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1243     {
1244       int i, compval;
1245       gfc_expr *shape1, *shape2;
1246
1247       if (r1->as->type != r2->as->type)
1248         {
1249           snprintf (errmsg, err_len, "Shape mismatch in function result");
1250           return FAILURE;
1251         }
1252
1253       if (r1->as->type == AS_EXPLICIT)
1254         for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1255           {
1256             shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1257                                    gfc_copy_expr (r1->as->lower[i]));
1258             shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1259                                    gfc_copy_expr (r2->as->lower[i]));
1260             compval = gfc_dep_compare_expr (shape1, shape2);
1261             gfc_free_expr (shape1);
1262             gfc_free_expr (shape2);
1263             switch (compval)
1264             {
1265               case -1:
1266               case  1:
1267               case -3:
1268                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1269                           "function result", i + 1);
1270                 return FAILURE;
1271
1272               case -2:
1273                 /* FIXME: Implement a warning for this case.
1274                 gfc_warning ("Possible shape mismatch in return value");*/
1275                 break;
1276
1277               case 0:
1278                 break;
1279
1280               default:
1281                 gfc_internal_error ("check_result_characteristics (2): "
1282                                     "Unexpected result %i of "
1283                                     "gfc_dep_compare_expr", compval);
1284                 break;
1285             }
1286           }
1287     }
1288
1289   return SUCCESS;
1290 }
1291
1292
1293 /* 'Compare' two formal interfaces associated with a pair of symbols.
1294    We return nonzero if there exists an actual argument list that
1295    would be ambiguous between the two interfaces, zero otherwise.
1296    'strict_flag' specifies whether all the characteristics are
1297    required to match, which is not the case for ambiguity checks.
1298    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
1299
1300 int
1301 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1302                         int generic_flag, int strict_flag,
1303                         char *errmsg, int err_len,
1304                         const char *p1, const char *p2)
1305 {
1306   gfc_formal_arglist *f1, *f2;
1307
1308   gcc_assert (name2 != NULL);
1309
1310   if (s1->attr.function && (s2->attr.subroutine
1311       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1312           && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1313     {
1314       if (errmsg != NULL)
1315         snprintf (errmsg, err_len, "'%s' is not a function", name2);
1316       return 0;
1317     }
1318
1319   if (s1->attr.subroutine && s2->attr.function)
1320     {
1321       if (errmsg != NULL)
1322         snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1323       return 0;
1324     }
1325
1326   /* Do strict checks on all characteristics
1327      (for dummy procedures and procedure pointer assignments).  */
1328   if (!generic_flag && strict_flag)
1329     {
1330       if (s1->attr.function && s2->attr.function)
1331         {
1332           /* If both are functions, check result characteristics.  */
1333           if (check_result_characteristics (s1, s2, errmsg, err_len)
1334               == FAILURE)
1335             return 0;
1336         }
1337
1338       if (s1->attr.pure && !s2->attr.pure)
1339         {
1340           snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1341           return 0;
1342         }
1343       if (s1->attr.elemental && !s2->attr.elemental)
1344         {
1345           snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1346           return 0;
1347         }
1348     }
1349
1350   if (s1->attr.if_source == IFSRC_UNKNOWN
1351       || s2->attr.if_source == IFSRC_UNKNOWN)
1352     return 1;
1353
1354   f1 = s1->formal;
1355   f2 = s2->formal;
1356
1357   if (f1 == NULL && f2 == NULL)
1358     return 1;                   /* Special case: No arguments.  */
1359
1360   if (generic_flag)
1361     {
1362       if (count_types_test (f1, f2, p1, p2)
1363           || count_types_test (f2, f1, p2, p1))
1364         return 0;
1365       if (generic_correspondence (f1, f2, p1, p2)
1366           || generic_correspondence (f2, f1, p2, p1))
1367         return 0;
1368     }
1369   else
1370     /* Perform the abbreviated correspondence test for operators (the
1371        arguments cannot be optional and are always ordered correctly).
1372        This is also done when comparing interfaces for dummy procedures and in
1373        procedure pointer assignments.  */
1374
1375     for (;;)
1376       {
1377         /* Check existence.  */
1378         if (f1 == NULL && f2 == NULL)
1379           break;
1380         if (f1 == NULL || f2 == NULL)
1381           {
1382             if (errmsg != NULL)
1383               snprintf (errmsg, err_len, "'%s' has the wrong number of "
1384                         "arguments", name2);
1385             return 0;
1386           }
1387
1388         if (strict_flag)
1389           {
1390             /* Check all characteristics.  */
1391             if (check_dummy_characteristics (f1->sym, f2->sym,
1392                                              true, errmsg, err_len) == FAILURE)
1393               return 0;
1394           }
1395         else if (!compare_type_rank (f2->sym, f1->sym))
1396           {
1397             /* Only check type and rank.  */
1398             if (errmsg != NULL)
1399               snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1400                         f1->sym->name);
1401             return 0;
1402           }
1403
1404         f1 = f1->next;
1405         f2 = f2->next;
1406       }
1407
1408   return 1;
1409 }
1410
1411
1412 /* Given a pointer to an interface pointer, remove duplicate
1413    interfaces and make sure that all symbols are either functions
1414    or subroutines, and all of the same kind.  Returns nonzero if
1415    something goes wrong.  */
1416
1417 static int
1418 check_interface0 (gfc_interface *p, const char *interface_name)
1419 {
1420   gfc_interface *psave, *q, *qlast;
1421
1422   psave = p;
1423   for (; p; p = p->next)
1424     {
1425       /* Make sure all symbols in the interface have been defined as
1426          functions or subroutines.  */
1427       if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1428            || !p->sym->attr.if_source)
1429           && p->sym->attr.flavor != FL_DERIVED)
1430         {
1431           if (p->sym->attr.external)
1432             gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1433                        p->sym->name, interface_name, &p->sym->declared_at);
1434           else
1435             gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1436                        "subroutine", p->sym->name, interface_name,
1437                       &p->sym->declared_at);
1438           return 1;
1439         }
1440
1441       /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
1442       if ((psave->sym->attr.function && !p->sym->attr.function
1443            && p->sym->attr.flavor != FL_DERIVED)
1444           || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1445         {
1446           if (p->sym->attr.flavor != FL_DERIVED)
1447             gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1448                        " or all FUNCTIONs", interface_name,
1449                        &p->sym->declared_at);
1450           else
1451             gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1452                        "generic name is also the name of a derived type",
1453                        interface_name, &p->sym->declared_at);
1454           return 1;
1455         }
1456
1457       /* F2003, C1207. F2008, C1207.  */
1458       if (p->sym->attr.proc == PROC_INTERNAL
1459           && gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1460                              "'%s' in %s at %L", p->sym->name, interface_name,
1461                              &p->sym->declared_at) == FAILURE)
1462         return 1;
1463     }
1464   p = psave;
1465
1466   /* Remove duplicate interfaces in this interface list.  */
1467   for (; p; p = p->next)
1468     {
1469       qlast = p;
1470
1471       for (q = p->next; q;)
1472         {
1473           if (p->sym != q->sym)
1474             {
1475               qlast = q;
1476               q = q->next;
1477             }
1478           else
1479             {
1480               /* Duplicate interface.  */
1481               qlast->next = q->next;
1482               free (q);
1483               q = qlast->next;
1484             }
1485         }
1486     }
1487
1488   return 0;
1489 }
1490
1491
1492 /* Check lists of interfaces to make sure that no two interfaces are
1493    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
1494
1495 static int
1496 check_interface1 (gfc_interface *p, gfc_interface *q0,
1497                   int generic_flag, const char *interface_name,
1498                   bool referenced)
1499 {
1500   gfc_interface *q;
1501   for (; p; p = p->next)
1502     for (q = q0; q; q = q->next)
1503       {
1504         if (p->sym == q->sym)
1505           continue;             /* Duplicates OK here.  */
1506
1507         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1508           continue;
1509
1510         if (p->sym->attr.flavor != FL_DERIVED
1511             && q->sym->attr.flavor != FL_DERIVED
1512             && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1513                                        generic_flag, 0, NULL, 0, NULL, NULL))
1514           {
1515             if (referenced)
1516               gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1517                          p->sym->name, q->sym->name, interface_name,
1518                          &p->where);
1519             else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1520               gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1521                            p->sym->name, q->sym->name, interface_name,
1522                            &p->where);
1523             else
1524               gfc_warning ("Although not referenced, '%s' has ambiguous "
1525                            "interfaces at %L", interface_name, &p->where);
1526             return 1;
1527           }
1528       }
1529   return 0;
1530 }
1531
1532
1533 /* Check the generic and operator interfaces of symbols to make sure
1534    that none of the interfaces conflict.  The check has to be done
1535    after all of the symbols are actually loaded.  */
1536
1537 static void
1538 check_sym_interfaces (gfc_symbol *sym)
1539 {
1540   char interface_name[100];
1541   gfc_interface *p;
1542
1543   if (sym->ns != gfc_current_ns)
1544     return;
1545
1546   if (sym->generic != NULL)
1547     {
1548       sprintf (interface_name, "generic interface '%s'", sym->name);
1549       if (check_interface0 (sym->generic, interface_name))
1550         return;
1551
1552       for (p = sym->generic; p; p = p->next)
1553         {
1554           if (sym->attr.access != ACCESS_PRIVATE)
1555             p->sym->attr.public_used = 1;
1556
1557           if (p->sym->attr.mod_proc
1558               && (p->sym->attr.if_source != IFSRC_DECL
1559                   || p->sym->attr.procedure))
1560             {
1561               gfc_error ("'%s' at %L is not a module procedure",
1562                          p->sym->name, &p->where);
1563               return;
1564             }
1565         }
1566
1567       /* Originally, this test was applied to host interfaces too;
1568          this is incorrect since host associated symbols, from any
1569          source, cannot be ambiguous with local symbols.  */
1570       check_interface1 (sym->generic, sym->generic, 1, interface_name,
1571                         sym->attr.referenced || !sym->attr.use_assoc);
1572     }
1573 }
1574
1575
1576 static void
1577 check_uop_interfaces (gfc_user_op *uop)
1578 {
1579   char interface_name[100];
1580   gfc_user_op *uop2;
1581   gfc_namespace *ns;
1582   gfc_interface *p;
1583
1584   sprintf (interface_name, "operator interface '%s'", uop->name);
1585   if (check_interface0 (uop->op, interface_name))
1586     return;
1587
1588   if (uop->access != ACCESS_PRIVATE)
1589     for (p = uop->op; p; p = p->next)
1590       p->sym->attr.public_used = 1;
1591
1592   for (ns = gfc_current_ns; ns; ns = ns->parent)
1593     {
1594       uop2 = gfc_find_uop (uop->name, ns);
1595       if (uop2 == NULL)
1596         continue;
1597
1598       check_interface1 (uop->op, uop2->op, 0,
1599                         interface_name, true);
1600     }
1601 }
1602
1603 /* Given an intrinsic op, return an equivalent op if one exists,
1604    or INTRINSIC_NONE otherwise.  */
1605
1606 gfc_intrinsic_op
1607 gfc_equivalent_op (gfc_intrinsic_op op)
1608 {
1609   switch(op)
1610     {
1611     case INTRINSIC_EQ:
1612       return INTRINSIC_EQ_OS;
1613
1614     case INTRINSIC_EQ_OS:
1615       return INTRINSIC_EQ;
1616
1617     case INTRINSIC_NE:
1618       return INTRINSIC_NE_OS;
1619
1620     case INTRINSIC_NE_OS:
1621       return INTRINSIC_NE;
1622
1623     case INTRINSIC_GT:
1624       return INTRINSIC_GT_OS;
1625
1626     case INTRINSIC_GT_OS:
1627       return INTRINSIC_GT;
1628
1629     case INTRINSIC_GE:
1630       return INTRINSIC_GE_OS;
1631
1632     case INTRINSIC_GE_OS:
1633       return INTRINSIC_GE;
1634
1635     case INTRINSIC_LT:
1636       return INTRINSIC_LT_OS;
1637
1638     case INTRINSIC_LT_OS:
1639       return INTRINSIC_LT;
1640
1641     case INTRINSIC_LE:
1642       return INTRINSIC_LE_OS;
1643
1644     case INTRINSIC_LE_OS:
1645       return INTRINSIC_LE;
1646
1647     default:
1648       return INTRINSIC_NONE;
1649     }
1650 }
1651
1652 /* For the namespace, check generic, user operator and intrinsic
1653    operator interfaces for consistency and to remove duplicate
1654    interfaces.  We traverse the whole namespace, counting on the fact
1655    that most symbols will not have generic or operator interfaces.  */
1656
1657 void
1658 gfc_check_interfaces (gfc_namespace *ns)
1659 {
1660   gfc_namespace *old_ns, *ns2;
1661   gfc_interface *p;
1662   char interface_name[100];
1663   int i;
1664
1665   old_ns = gfc_current_ns;
1666   gfc_current_ns = ns;
1667
1668   gfc_traverse_ns (ns, check_sym_interfaces);
1669
1670   gfc_traverse_user_op (ns, check_uop_interfaces);
1671
1672   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1673     {
1674       if (i == INTRINSIC_USER)
1675         continue;
1676
1677       if (i == INTRINSIC_ASSIGN)
1678         strcpy (interface_name, "intrinsic assignment operator");
1679       else
1680         sprintf (interface_name, "intrinsic '%s' operator",
1681                  gfc_op2string ((gfc_intrinsic_op) i));
1682
1683       if (check_interface0 (ns->op[i], interface_name))
1684         continue;
1685
1686       for (p = ns->op[i]; p; p = p->next)
1687         p->sym->attr.public_used = 1;
1688
1689
1690       if (ns->op[i])
1691         gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1692                                       ns->op[i]->where);
1693
1694       for (ns2 = ns; ns2; ns2 = ns2->parent)
1695         {
1696           gfc_intrinsic_op other_op;
1697
1698           if (check_interface1 (ns->op[i], ns2->op[i], 0,
1699                                 interface_name, true))
1700             goto done;
1701
1702           /* i should be gfc_intrinsic_op, but has to be int with this cast
1703              here for stupid C++ compatibility rules.  */
1704           other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1705           if (other_op != INTRINSIC_NONE
1706             &&  check_interface1 (ns->op[i], ns2->op[other_op],
1707                                   0, interface_name, true))
1708             goto done;
1709         }
1710     }
1711
1712 done:
1713   gfc_current_ns = old_ns;
1714 }
1715
1716
1717 static int
1718 symbol_rank (gfc_symbol *sym)
1719 {
1720   if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1721     return CLASS_DATA (sym)->as->rank;
1722
1723   return (sym->as == NULL) ? 0 : sym->as->rank;
1724 }
1725
1726
1727 /* Given a symbol of a formal argument list and an expression, if the
1728    formal argument is allocatable, check that the actual argument is
1729    allocatable. Returns nonzero if compatible, zero if not compatible.  */
1730
1731 static int
1732 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1733 {
1734   symbol_attribute attr;
1735
1736   if (formal->attr.allocatable
1737       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1738     {
1739       attr = gfc_expr_attr (actual);
1740       if (!attr.allocatable)
1741         return 0;
1742     }
1743
1744   return 1;
1745 }
1746
1747
1748 /* Given a symbol of a formal argument list and an expression, if the
1749    formal argument is a pointer, see if the actual argument is a
1750    pointer. Returns nonzero if compatible, zero if not compatible.  */
1751
1752 static int
1753 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1754 {
1755   symbol_attribute attr;
1756
1757   if (formal->attr.pointer
1758       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
1759           && CLASS_DATA (formal)->attr.class_pointer))
1760     {
1761       attr = gfc_expr_attr (actual);
1762
1763       /* Fortran 2008 allows non-pointer actual arguments.  */
1764       if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1765         return 2;
1766
1767       if (!attr.pointer)
1768         return 0;
1769     }
1770
1771   return 1;
1772 }
1773
1774
1775 /* Emit clear error messages for rank mismatch.  */
1776
1777 static void
1778 argument_rank_mismatch (const char *name, locus *where,
1779                         int rank1, int rank2)
1780 {
1781
1782   /* TS 29113, C407b.  */
1783   if (rank2 == -1)
1784     {
1785       gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1786                  " '%s' has assumed-rank", where, name);
1787     }
1788   else if (rank1 == 0)
1789     {
1790       gfc_error ("Rank mismatch in argument '%s' at %L "
1791                  "(scalar and rank-%d)", name, where, rank2);
1792     }
1793   else if (rank2 == 0)
1794     {
1795       gfc_error ("Rank mismatch in argument '%s' at %L "
1796                  "(rank-%d and scalar)", name, where, rank1);
1797     }
1798   else
1799     {
1800       gfc_error ("Rank mismatch in argument '%s' at %L "
1801                  "(rank-%d and rank-%d)", name, where, rank1, rank2);
1802     }
1803 }
1804
1805
1806 /* Given a symbol of a formal argument list and an expression, see if
1807    the two are compatible as arguments.  Returns nonzero if
1808    compatible, zero if not compatible.  */
1809
1810 static int
1811 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1812                    int ranks_must_agree, int is_elemental, locus *where)
1813 {
1814   gfc_ref *ref;
1815   bool rank_check, is_pointer;
1816
1817   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1818      procs c_f_pointer or c_f_procpointer, and we need to accept most
1819      pointers the user could give us.  This should allow that.  */
1820   if (formal->ts.type == BT_VOID)
1821     return 1;
1822
1823   if (formal->ts.type == BT_DERIVED
1824       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1825       && actual->ts.type == BT_DERIVED
1826       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1827     return 1;
1828
1829   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1830     /* Make sure the vtab symbol is present when
1831        the module variables are generated.  */
1832     gfc_find_derived_vtab (actual->ts.u.derived);
1833
1834   if (actual->ts.type == BT_PROCEDURE)
1835     {
1836       char err[200];
1837       gfc_symbol *act_sym = actual->symtree->n.sym;
1838
1839       if (formal->attr.flavor != FL_PROCEDURE)
1840         {
1841           if (where)
1842             gfc_error ("Invalid procedure argument at %L", &actual->where);
1843           return 0;
1844         }
1845
1846       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1847                                    sizeof(err), NULL, NULL))
1848         {
1849           if (where)
1850             gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1851                        formal->name, &actual->where, err);
1852           return 0;
1853         }
1854
1855       if (formal->attr.function && !act_sym->attr.function)
1856         {
1857           gfc_add_function (&act_sym->attr, act_sym->name,
1858           &act_sym->declared_at);
1859           if (act_sym->ts.type == BT_UNKNOWN
1860               && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1861             return 0;
1862         }
1863       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1864         gfc_add_subroutine (&act_sym->attr, act_sym->name,
1865                             &act_sym->declared_at);
1866
1867       return 1;
1868     }
1869
1870   /* F2008, C1241.  */
1871   if (formal->attr.pointer && formal->attr.contiguous
1872       && !gfc_is_simply_contiguous (actual, true))
1873     {
1874       if (where)
1875         gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1876                    "must be simply contiguous", formal->name, &actual->where);
1877       return 0;
1878     }
1879
1880   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1881       && actual->ts.type != BT_HOLLERITH
1882       && formal->ts.type != BT_ASSUMED
1883       && !gfc_compare_types (&formal->ts, &actual->ts)
1884       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
1885            && gfc_compare_derived_types (formal->ts.u.derived,
1886                                          CLASS_DATA (actual)->ts.u.derived)))
1887     {
1888       if (where)
1889         gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1890                    formal->name, &actual->where, gfc_typename (&actual->ts),
1891                    gfc_typename (&formal->ts));
1892       return 0;
1893     }
1894
1895   /* F2008, 12.5.2.5; IR F08/0073.  */
1896   if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
1897       && ((CLASS_DATA (formal)->attr.class_pointer
1898            && !formal->attr.intent == INTENT_IN)
1899           || CLASS_DATA (formal)->attr.allocatable))
1900     {
1901       if (actual->ts.type != BT_CLASS)
1902         {
1903           if (where)
1904             gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1905                         formal->name, &actual->where);
1906           return 0;
1907         }
1908       if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
1909                                       CLASS_DATA (formal)->ts.u.derived))
1910         {
1911           if (where)
1912             gfc_error ("Actual argument to '%s' at %L must have the same "
1913                        "declared type", formal->name, &actual->where);
1914           return 0;
1915         }
1916     }
1917
1918   if (formal->attr.codimension && !gfc_is_coarray (actual))
1919     {
1920       if (where)
1921         gfc_error ("Actual argument to '%s' at %L must be a coarray",
1922                        formal->name, &actual->where);
1923       return 0;
1924     }
1925
1926   if (formal->attr.codimension && formal->attr.allocatable)
1927     {
1928       gfc_ref *last = NULL;
1929
1930       for (ref = actual->ref; ref; ref = ref->next)
1931         if (ref->type == REF_COMPONENT)
1932           last = ref;
1933
1934       /* F2008, 12.5.2.6.  */
1935       if ((last && last->u.c.component->as->corank != formal->as->corank)
1936           || (!last
1937               && actual->symtree->n.sym->as->corank != formal->as->corank))
1938         {
1939           if (where)
1940             gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1941                    formal->name, &actual->where, formal->as->corank,
1942                    last ? last->u.c.component->as->corank
1943                         : actual->symtree->n.sym->as->corank);
1944           return 0;
1945         }
1946     }
1947
1948   if (formal->attr.codimension)
1949     {
1950       /* F2008, 12.5.2.8.  */
1951       if (formal->attr.dimension
1952           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1953           && gfc_expr_attr (actual).dimension
1954           && !gfc_is_simply_contiguous (actual, true))
1955         {
1956           if (where)
1957             gfc_error ("Actual argument to '%s' at %L must be simply "
1958                        "contiguous", formal->name, &actual->where);
1959           return 0;
1960         }
1961
1962       /* F2008, C1303 and C1304.  */
1963       if (formal->attr.intent != INTENT_INOUT
1964           && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1965                && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1966                && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1967               || formal->attr.lock_comp))
1968
1969         {
1970           if (where)
1971             gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1972                        "which is LOCK_TYPE or has a LOCK_TYPE component",
1973                        formal->name, &actual->where);
1974           return 0;
1975         }
1976     }
1977
1978   /* F2008, C1239/C1240.  */
1979   if (actual->expr_type == EXPR_VARIABLE
1980       && (actual->symtree->n.sym->attr.asynchronous
1981          || actual->symtree->n.sym->attr.volatile_)
1982       &&  (formal->attr.asynchronous || formal->attr.volatile_)
1983       && actual->rank && !gfc_is_simply_contiguous (actual, true)
1984       && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1985           || formal->attr.contiguous))
1986     {
1987       if (where)
1988         gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1989                    "array without CONTIGUOUS attribute - as actual argument at"
1990                    " %L is not simply contiguous and both are ASYNCHRONOUS "
1991                    "or VOLATILE", formal->name, &actual->where);
1992       return 0;
1993     }
1994
1995   if (formal->attr.allocatable && !formal->attr.codimension
1996       && gfc_expr_attr (actual).codimension)
1997     {
1998       if (formal->attr.intent == INTENT_OUT)
1999         {
2000           if (where)
2001             gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2002                        "INTENT(OUT) dummy argument '%s'", &actual->where,
2003                        formal->name);
2004             return 0;
2005         }
2006       else if (gfc_option.warn_surprising && where
2007                && formal->attr.intent != INTENT_IN)
2008         gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2009                      "argument '%s', which is invalid if the allocation status"
2010                      " is modified",  &actual->where, formal->name);
2011     }
2012
2013   /* If the rank is the same or the formal argument has assumed-rank.  */
2014   if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2015     return 1;
2016
2017   if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
2018         && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
2019     return 1;
2020
2021   rank_check = where != NULL && !is_elemental && formal->as
2022                && (formal->as->type == AS_ASSUMED_SHAPE
2023                    || formal->as->type == AS_DEFERRED)
2024                && actual->expr_type != EXPR_NULL;
2025
2026   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
2027   if (rank_check || ranks_must_agree
2028       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2029       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2030       || (actual->rank == 0
2031           && ((formal->ts.type == BT_CLASS
2032                && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2033               || (formal->ts.type != BT_CLASS
2034                    && formal->as->type == AS_ASSUMED_SHAPE))
2035           && actual->expr_type != EXPR_NULL)
2036       || (actual->rank == 0 && formal->attr.dimension
2037           && gfc_is_coindexed (actual)))
2038     {
2039       if (where)
2040         argument_rank_mismatch (formal->name, &actual->where,
2041                                 symbol_rank (formal), actual->rank);
2042       return 0;
2043     }
2044   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2045     return 1;
2046
2047   /* At this point, we are considering a scalar passed to an array.   This
2048      is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2049      - if the actual argument is (a substring of) an element of a
2050        non-assumed-shape/non-pointer/non-polymorphic array; or
2051      - (F2003) if the actual argument is of type character of default/c_char
2052        kind.  */
2053
2054   is_pointer = actual->expr_type == EXPR_VARIABLE
2055                ? actual->symtree->n.sym->attr.pointer : false;
2056
2057   for (ref = actual->ref; ref; ref = ref->next)
2058     {
2059       if (ref->type == REF_COMPONENT)
2060         is_pointer = ref->u.c.component->attr.pointer;
2061       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2062                && ref->u.ar.dimen > 0
2063                && (!ref->next
2064                    || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2065         break;
2066     }
2067
2068   if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2069     {
2070       if (where)
2071         gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2072                    "at %L", formal->name, &actual->where);
2073       return 0;
2074     }
2075
2076   if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2077       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2078     {
2079       if (where)
2080         gfc_error ("Element of assumed-shaped or pointer "
2081                    "array passed to array dummy argument '%s' at %L",
2082                    formal->name, &actual->where);
2083       return 0;
2084     }
2085
2086   if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2087       && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2088     {
2089       if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2090         {
2091           if (where)
2092             gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2093                        "CHARACTER actual argument with array dummy argument "
2094                        "'%s' at %L", formal->name, &actual->where);
2095           return 0;
2096         }
2097
2098       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2099         {
2100           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2101                      "array dummy argument '%s' at %L",
2102                      formal->name, &actual->where);
2103           return 0;
2104         }
2105       else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
2106         return 0;
2107       else
2108         return 1;
2109     }
2110
2111   if (ref == NULL && actual->expr_type != EXPR_NULL)
2112     {
2113       if (where)
2114         argument_rank_mismatch (formal->name, &actual->where,
2115                                 symbol_rank (formal), actual->rank);
2116       return 0;
2117     }
2118
2119   return 1;
2120 }
2121
2122
2123 /* Returns the storage size of a symbol (formal argument) or
2124    zero if it cannot be determined.  */
2125
2126 static unsigned long
2127 get_sym_storage_size (gfc_symbol *sym)
2128 {
2129   int i;
2130   unsigned long strlen, elements;
2131
2132   if (sym->ts.type == BT_CHARACTER)
2133     {
2134       if (sym->ts.u.cl && sym->ts.u.cl->length
2135           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2136         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2137       else
2138         return 0;
2139     }
2140   else
2141     strlen = 1;
2142
2143   if (symbol_rank (sym) == 0)
2144     return strlen;
2145
2146   elements = 1;
2147   if (sym->as->type != AS_EXPLICIT)
2148     return 0;
2149   for (i = 0; i < sym->as->rank; i++)
2150     {
2151       if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
2152           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2153         return 0;
2154
2155       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2156                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2157     }
2158
2159   return strlen*elements;
2160 }
2161
2162
2163 /* Returns the storage size of an expression (actual argument) or
2164    zero if it cannot be determined. For an array element, it returns
2165    the remaining size as the element sequence consists of all storage
2166    units of the actual argument up to the end of the array.  */
2167
2168 static unsigned long
2169 get_expr_storage_size (gfc_expr *e)
2170 {
2171   int i;
2172   long int strlen, elements;
2173   long int substrlen = 0;
2174   bool is_str_storage = false;
2175   gfc_ref *ref;
2176
2177   if (e == NULL)
2178     return 0;
2179
2180   if (e->ts.type == BT_CHARACTER)
2181     {
2182       if (e->ts.u.cl && e->ts.u.cl->length
2183           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2184         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2185       else if (e->expr_type == EXPR_CONSTANT
2186                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2187         strlen = e->value.character.length;
2188       else
2189         return 0;
2190     }
2191   else
2192     strlen = 1; /* Length per element.  */
2193
2194   if (e->rank == 0 && !e->ref)
2195     return strlen;
2196
2197   elements = 1;
2198   if (!e->ref)
2199     {
2200       if (!e->shape)
2201         return 0;
2202       for (i = 0; i < e->rank; i++)
2203         elements *= mpz_get_si (e->shape[i]);
2204       return elements*strlen;
2205     }
2206
2207   for (ref = e->ref; ref; ref = ref->next)
2208     {
2209       if (ref->type == REF_SUBSTRING && ref->u.ss.start
2210           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2211         {
2212           if (is_str_storage)
2213             {
2214               /* The string length is the substring length.
2215                  Set now to full string length.  */
2216               if (!ref->u.ss.length || !ref->u.ss.length->length
2217                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2218                 return 0;
2219
2220               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2221             }
2222           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2223           continue;
2224         }
2225
2226       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
2227           && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
2228           && ref->u.ar.as->upper)
2229         for (i = 0; i < ref->u.ar.dimen; i++)
2230           {
2231             long int start, end, stride;
2232             stride = 1;
2233
2234             if (ref->u.ar.stride[i])
2235               {
2236                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2237                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2238                 else
2239                   return 0;
2240               }
2241
2242             if (ref->u.ar.start[i])
2243               {
2244                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2245                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2246                 else
2247                   return 0;
2248               }
2249             else if (ref->u.ar.as->lower[i]
2250                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2251               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2252             else
2253               return 0;
2254
2255             if (ref->u.ar.end[i])
2256               {
2257                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2258                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2259                 else
2260                   return 0;
2261               }
2262             else if (ref->u.ar.as->upper[i]
2263                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2264               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2265             else
2266               return 0;
2267
2268             elements *= (end - start)/stride + 1L;
2269           }
2270       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
2271                && ref->u.ar.as->lower && ref->u.ar.as->upper)
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               continue;
3391             derived = CLASS_DATA (base->expr)->ts.u.derived;
3392           }
3393         else
3394           derived = base->expr->ts.u.derived;
3395
3396         if (op == INTRINSIC_USER)
3397           {
3398             gfc_symtree* tb_uop;
3399
3400             gcc_assert (uop);
3401             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3402                                                  false, NULL);
3403
3404             if (tb_uop)
3405               tb = tb_uop->n.tb;
3406             else
3407               tb = NULL;
3408           }
3409         else
3410           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3411                                                 false, NULL);
3412
3413         /* This means we hit a PRIVATE operator which is use-associated and
3414            should thus not be seen.  */
3415         if (result == FAILURE)
3416           tb = NULL;
3417
3418         /* Look through the super-type hierarchy for a matching specific
3419            binding.  */
3420         for (; tb; tb = tb->overridden)
3421           {
3422             gfc_tbp_generic* g;
3423
3424             gcc_assert (tb->is_generic);
3425             for (g = tb->u.generic; g; g = g->next)
3426               {
3427                 gfc_symbol* target;
3428                 gfc_actual_arglist* argcopy;
3429                 bool matches;
3430
3431                 gcc_assert (g->specific);
3432                 if (g->specific->error)
3433                   continue;
3434
3435                 target = g->specific->u.specific->n.sym;
3436
3437                 /* Check if this arglist matches the formal.  */
3438                 argcopy = gfc_copy_actual_arglist (args);
3439                 matches = gfc_arglist_matches_symbol (&argcopy, target);
3440                 gfc_free_actual_arglist (argcopy);
3441
3442                 /* Return if we found a match.  */
3443                 if (matches)
3444                   {
3445                     *tb_base = base->expr;
3446                     *gname = g->specific_st->name;
3447                     return g->specific;
3448                   }
3449               }
3450           }
3451       }
3452
3453   return NULL;
3454 }
3455
3456
3457 /* For the 'actual arglist' of an operator call and a specific typebound
3458    procedure that has been found the target of a type-bound operator, build the
3459    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
3460    type-bound procedures rather than resolving type-bound operators 'directly'
3461    so that we can reuse the existing logic.  */
3462
3463 static void
3464 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3465                              gfc_expr* base, gfc_typebound_proc* target,
3466                              const char *gname)
3467 {
3468   e->expr_type = EXPR_COMPCALL;
3469   e->value.compcall.tbp = target;
3470   e->value.compcall.name = gname ? gname : "$op";
3471   e->value.compcall.actual = actual;
3472   e->value.compcall.base_object = base;
3473   e->value.compcall.ignore_pass = 1;
3474   e->value.compcall.assign = 0;
3475   if (e->ts.type == BT_UNKNOWN
3476         && target->function)
3477     {
3478       if (target->is_generic)
3479         e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3480       else
3481         e->ts = target->u.specific->n.sym->ts;
3482     }
3483 }
3484
3485
3486 /* This subroutine is called when an expression is being resolved.
3487    The expression node in question is either a user defined operator
3488    or an intrinsic operator with arguments that aren't compatible
3489    with the operator.  This subroutine builds an actual argument list
3490    corresponding to the operands, then searches for a compatible
3491    interface.  If one is found, the expression node is replaced with
3492    the appropriate function call. We use the 'match' enum to specify
3493    whether a replacement has been made or not, or if an error occurred.  */
3494
3495 match
3496 gfc_extend_expr (gfc_expr *e)
3497 {
3498   gfc_actual_arglist *actual;
3499   gfc_symbol *sym;
3500   gfc_namespace *ns;
3501   gfc_user_op *uop;
3502   gfc_intrinsic_op i;
3503   const char *gname;
3504
3505   sym = NULL;
3506
3507   actual = gfc_get_actual_arglist ();
3508   actual->expr = e->value.op.op1;
3509
3510   gname = NULL;
3511
3512   if (e->value.op.op2 != NULL)
3513     {
3514       actual->next = gfc_get_actual_arglist ();
3515       actual->next->expr = e->value.op.op2;
3516     }
3517
3518   i = fold_unary_intrinsic (e->value.op.op);
3519
3520   if (i == INTRINSIC_USER)
3521     {
3522       for (ns = gfc_current_ns; ns; ns = ns->parent)
3523         {
3524           uop = gfc_find_uop (e->value.op.uop->name, ns);
3525           if (uop == NULL)
3526             continue;
3527
3528           sym = gfc_search_interface (uop->op, 0, &actual);
3529           if (sym != NULL)
3530             break;
3531         }
3532     }
3533   else
3534     {
3535       for (ns = gfc_current_ns; ns; ns = ns->parent)
3536         {
3537           /* Due to the distinction between '==' and '.eq.' and friends, one has
3538              to check if either is defined.  */
3539           switch (i)
3540             {
3541 #define CHECK_OS_COMPARISON(comp) \
3542   case INTRINSIC_##comp: \
3543   case INTRINSIC_##comp##_OS: \
3544     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3545     if (!sym) \
3546       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3547     break;
3548               CHECK_OS_COMPARISON(EQ)
3549               CHECK_OS_COMPARISON(NE)
3550               CHECK_OS_COMPARISON(GT)
3551               CHECK_OS_COMPARISON(GE)
3552               CHECK_OS_COMPARISON(LT)
3553               CHECK_OS_COMPARISON(LE)
3554 #undef CHECK_OS_COMPARISON
3555
3556               default:
3557                 sym = gfc_search_interface (ns->op[i], 0, &actual);
3558             }
3559
3560           if (sym != NULL)
3561             break;
3562         }
3563     }
3564
3565   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3566      found rather than just taking the first one and not checking further.  */
3567
3568   if (sym == NULL)
3569     {
3570       gfc_typebound_proc* tbo;
3571       gfc_expr* tb_base;
3572
3573       /* See if we find a matching type-bound operator.  */
3574       if (i == INTRINSIC_USER)
3575         tbo = matching_typebound_op (&tb_base, actual,
3576                                      i, e->value.op.uop->name, &gname);
3577       else
3578         switch (i)
3579           {
3580 #define CHECK_OS_COMPARISON(comp) \
3581   case INTRINSIC_##comp: \
3582   case INTRINSIC_##comp##_OS: \
3583     tbo = matching_typebound_op (&tb_base, actual, \
3584                                  INTRINSIC_##comp, NULL, &gname); \
3585     if (!tbo) \
3586       tbo = matching_typebound_op (&tb_base, actual, \
3587                                    INTRINSIC_##comp##_OS, NULL, &gname); \
3588     break;
3589             CHECK_OS_COMPARISON(EQ)
3590             CHECK_OS_COMPARISON(NE)
3591             CHECK_OS_COMPARISON(GT)
3592             CHECK_OS_COMPARISON(GE)
3593             CHECK_OS_COMPARISON(LT)
3594             CHECK_OS_COMPARISON(LE)
3595 #undef CHECK_OS_COMPARISON
3596
3597             default:
3598               tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3599               break;
3600           }
3601
3602       /* If there is a matching typebound-operator, replace the expression with
3603          a call to it and succeed.  */
3604       if (tbo)
3605         {
3606           gfc_try result;
3607
3608           gcc_assert (tb_base);
3609           build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3610
3611           result = gfc_resolve_expr (e);
3612           if (result == FAILURE)
3613             return MATCH_ERROR;
3614
3615           return MATCH_YES;
3616         }
3617
3618       /* Don't use gfc_free_actual_arglist().  */
3619       free (actual->next);
3620       free (actual);
3621
3622       return MATCH_NO;
3623     }
3624
3625   /* Change the expression node to a function call.  */
3626   e->expr_type = EXPR_FUNCTION;
3627   e->symtree = gfc_find_sym_in_symtree (sym);
3628   e->value.function.actual = actual;
3629   e->value.function.esym = NULL;
3630   e->value.function.isym = NULL;
3631   e->value.function.name = NULL;
3632   e->user_operator = 1;
3633
3634   if (gfc_resolve_expr (e) == FAILURE)
3635     return MATCH_ERROR;
3636
3637   return MATCH_YES;
3638 }
3639
3640
3641 /* Tries to replace an assignment code node with a subroutine call to
3642    the subroutine associated with the assignment operator.  Return
3643    SUCCESS if the node was replaced.  On FAILURE, no error is
3644    generated.  */
3645
3646 gfc_try
3647 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3648 {
3649   gfc_actual_arglist *actual;
3650   gfc_expr *lhs, *rhs;
3651   gfc_symbol *sym;
3652   const char *gname;
3653
3654   gname = NULL;
3655
3656   lhs = c->expr1;
3657   rhs = c->expr2;
3658
3659   /* Don't allow an intrinsic assignment to be replaced.  */
3660   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3661       && (rhs->rank == 0 || rhs->rank == lhs->rank)
3662       && (lhs->ts.type == rhs->ts.type
3663           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3664     return FAILURE;
3665
3666   actual = gfc_get_actual_arglist ();
3667   actual->expr = lhs;
3668
3669   actual->next = gfc_get_actual_arglist ();
3670   actual->next->expr = rhs;
3671
3672   sym = NULL;
3673
3674   for (; ns; ns = ns->parent)
3675     {
3676       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3677       if (sym != NULL)
3678         break;
3679     }
3680
3681   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
3682
3683   if (sym == NULL)
3684     {
3685       gfc_typebound_proc* tbo;
3686       gfc_expr* tb_base;
3687
3688       /* See if we find a matching type-bound assignment.  */
3689       tbo = matching_typebound_op (&tb_base, actual,
3690                                    INTRINSIC_ASSIGN, NULL, &gname);
3691
3692       /* If there is one, replace the expression with a call to it and
3693          succeed.  */
3694       if (tbo)
3695         {
3696           gcc_assert (tb_base);
3697           c->expr1 = gfc_get_expr ();
3698           build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3699           c->expr1->value.compcall.assign = 1;
3700           c->expr1->where = c->loc;
3701           c->expr2 = NULL;
3702           c->op = EXEC_COMPCALL;
3703
3704           /* c is resolved from the caller, so no need to do it here.  */
3705
3706           return SUCCESS;
3707         }
3708
3709       free (actual->next);
3710       free (actual);
3711       return FAILURE;
3712     }
3713
3714   /* Replace the assignment with the call.  */
3715   c->op = EXEC_ASSIGN_CALL;
3716   c->symtree = gfc_find_sym_in_symtree (sym);
3717   c->expr1 = NULL;
3718   c->expr2 = NULL;
3719   c->ext.actual = actual;
3720
3721   return SUCCESS;
3722 }
3723
3724
3725 /* Make sure that the interface just parsed is not already present in
3726    the given interface list.  Ambiguity isn't checked yet since module
3727    procedures can be present without interfaces.  */
3728
3729 gfc_try
3730 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
3731 {
3732   gfc_interface *ip;
3733
3734   for (ip = base; ip; ip = ip->next)
3735     {
3736       if (ip->sym == new_sym)
3737         {
3738           gfc_error ("Entity '%s' at %L is already present in the interface",
3739                      new_sym->name, &loc);
3740           return FAILURE;
3741         }
3742     }
3743
3744   return SUCCESS;
3745 }
3746
3747
3748 /* Add a symbol to the current interface.  */
3749
3750 gfc_try
3751 gfc_add_interface (gfc_symbol *new_sym)
3752 {
3753   gfc_interface **head, *intr;
3754   gfc_namespace *ns;
3755   gfc_symbol *sym;
3756
3757   switch (current_interface.type)
3758     {
3759     case INTERFACE_NAMELESS:
3760     case INTERFACE_ABSTRACT:
3761       return SUCCESS;
3762
3763     case INTERFACE_INTRINSIC_OP:
3764       for (ns = current_interface.ns; ns; ns = ns->parent)
3765         switch (current_interface.op)
3766           {
3767             case INTRINSIC_EQ:
3768             case INTRINSIC_EQ_OS:
3769               if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
3770                                            gfc_current_locus) == FAILURE
3771                   || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
3772                                               gfc_current_locus) == FAILURE)
3773                 return FAILURE;
3774               break;
3775
3776             case INTRINSIC_NE:
3777             case INTRINSIC_NE_OS:
3778               if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
3779                                            gfc_current_locus) == FAILURE
3780                   || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
3781                                               gfc_current_locus) == FAILURE)
3782                 return FAILURE;
3783               break;
3784
3785             case INTRINSIC_GT:
3786             case INTRINSIC_GT_OS:
3787               if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
3788                                            gfc_current_locus) == FAILURE
3789                   || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
3790                                               gfc_current_locus) == FAILURE)
3791                 return FAILURE;
3792               break;
3793
3794             case INTRINSIC_GE:
3795             case INTRINSIC_GE_OS:
3796               if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
3797                                            gfc_current_locus) == FAILURE
3798                   || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
3799                                               gfc_current_locus) == FAILURE)
3800                 return FAILURE;
3801               break;
3802
3803             case INTRINSIC_LT:
3804             case INTRINSIC_LT_OS:
3805               if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
3806                                            gfc_current_locus) == FAILURE
3807                   || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
3808                                               gfc_current_locus) == FAILURE)
3809                 return FAILURE;
3810               break;
3811
3812             case INTRINSIC_LE:
3813             case INTRINSIC_LE_OS:
3814               if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
3815                                            gfc_current_locus) == FAILURE
3816                   || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
3817                                               gfc_current_locus) == FAILURE)
3818                 return FAILURE;
3819               break;
3820
3821             default:
3822               if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
3823                                            gfc_current_locus) == FAILURE)
3824                 return FAILURE;
3825           }
3826
3827       head = &current_interface.ns->op[current_interface.op];
3828       break;
3829
3830     case INTERFACE_GENERIC:
3831       for (ns = current_interface.ns; ns; ns = ns->parent)
3832         {
3833           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3834           if (sym == NULL)
3835             continue;
3836
3837           if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
3838               == FAILURE)
3839             return FAILURE;
3840         }
3841
3842       head = &current_interface.sym->generic;
3843       break;
3844
3845     case INTERFACE_USER_OP:
3846       if (gfc_check_new_interface (current_interface.uop->op, new_sym,
3847                                    gfc_current_locus) == FAILURE)
3848         return FAILURE;
3849
3850       head = &current_interface.uop->op;
3851       break;
3852
3853     default:
3854       gfc_internal_error ("gfc_add_interface(): Bad interface type");
3855     }
3856
3857   intr = gfc_get_interface ();
3858   intr->sym = new_sym;
3859   intr->where = gfc_current_locus;
3860
3861   intr->next = *head;
3862   *head = intr;
3863
3864   return SUCCESS;
3865 }
3866
3867
3868 gfc_interface *
3869 gfc_current_interface_head (void)
3870 {
3871   switch (current_interface.type)
3872     {
3873       case INTERFACE_INTRINSIC_OP:
3874         return current_interface.ns->op[current_interface.op];
3875         break;
3876
3877       case INTERFACE_GENERIC:
3878         return current_interface.sym->generic;
3879         break;
3880
3881       case INTERFACE_USER_OP:
3882         return current_interface.uop->op;
3883         break;
3884
3885       default:
3886         gcc_unreachable ();
3887     }
3888 }
3889
3890
3891 void
3892 gfc_set_current_interface_head (gfc_interface *i)
3893 {
3894   switch (current_interface.type)
3895     {
3896       case INTERFACE_INTRINSIC_OP:
3897         current_interface.ns->op[current_interface.op] = i;
3898         break;
3899
3900       case INTERFACE_GENERIC:
3901         current_interface.sym->generic = i;
3902         break;
3903
3904       case INTERFACE_USER_OP:
3905         current_interface.uop->op = i;
3906         break;
3907
3908       default:
3909         gcc_unreachable ();
3910     }
3911 }
3912
3913
3914 /* Gets rid of a formal argument list.  We do not free symbols.
3915    Symbols are freed when a namespace is freed.  */
3916
3917 void
3918 gfc_free_formal_arglist (gfc_formal_arglist *p)
3919 {
3920   gfc_formal_arglist *q;
3921
3922   for (; p; p = q)
3923     {
3924       q = p->next;
3925       free (p);
3926     }
3927 }
3928
3929
3930 /* Check that it is ok for the type-bound procedure 'proc' to override the
3931    procedure 'old', cf. F08:4.5.7.3.  */
3932
3933 gfc_try
3934 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3935 {
3936   locus where;
3937   gfc_symbol *proc_target, *old_target;
3938   unsigned proc_pass_arg, old_pass_arg, argpos;
3939   gfc_formal_arglist *proc_formal, *old_formal;
3940   bool check_type;
3941   char err[200];
3942
3943   /* This procedure should only be called for non-GENERIC proc.  */
3944   gcc_assert (!proc->n.tb->is_generic);
3945
3946   /* If the overwritten procedure is GENERIC, this is an error.  */
3947   if (old->n.tb->is_generic)
3948     {
3949       gfc_error ("Can't overwrite GENERIC '%s' at %L",
3950                  old->name, &proc->n.tb->where);
3951       return FAILURE;
3952     }
3953
3954   where = proc->n.tb->where;
3955   proc_target = proc->n.tb->u.specific->n.sym;
3956   old_target = old->n.tb->u.specific->n.sym;
3957
3958   /* Check that overridden binding is not NON_OVERRIDABLE.  */
3959   if (old->n.tb->non_overridable)
3960     {
3961       gfc_error ("'%s' at %L overrides a procedure binding declared"
3962                  " NON_OVERRIDABLE", proc->name, &where);
3963       return FAILURE;
3964     }
3965
3966   /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
3967   if (!old->n.tb->deferred && proc->n.tb->deferred)
3968     {
3969       gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3970                  " non-DEFERRED binding", proc->name, &where);
3971       return FAILURE;
3972     }
3973
3974   /* If the overridden binding is PURE, the overriding must be, too.  */
3975   if (old_target->attr.pure && !proc_target->attr.pure)
3976     {
3977       gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3978                  proc->name, &where);
3979       return FAILURE;
3980     }
3981
3982   /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
3983      is not, the overriding must not be either.  */
3984   if (old_target->attr.elemental && !proc_target->attr.elemental)
3985     {
3986       gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3987                  " ELEMENTAL", proc->name, &where);
3988       return FAILURE;
3989     }
3990   if (!old_target->attr.elemental && proc_target->attr.elemental)
3991     {
3992       gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3993                  " be ELEMENTAL, either", proc->name, &where);
3994       return FAILURE;
3995     }
3996
3997   /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3998      SUBROUTINE.  */
3999   if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4000     {
4001       gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4002                  " SUBROUTINE", proc->name, &where);
4003       return FAILURE;
4004     }
4005
4006   /* If the overridden binding is a FUNCTION, the overriding must also be a
4007      FUNCTION and have the same characteristics.  */
4008   if (old_target->attr.function)
4009     {
4010       if (!proc_target->attr.function)
4011         {
4012           gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4013                      " FUNCTION", proc->name, &where);
4014           return FAILURE;
4015         }
4016
4017       if (check_result_characteristics (proc_target, old_target,
4018                                         err, sizeof(err)) == FAILURE)
4019         {
4020           gfc_error ("Result mismatch for the overriding procedure "
4021                      "'%s' at %L: %s", proc->name, &where, err);
4022           return FAILURE;
4023         }
4024     }
4025
4026   /* If the overridden binding is PUBLIC, the overriding one must not be
4027      PRIVATE.  */
4028   if (old->n.tb->access == ACCESS_PUBLIC
4029       && proc->n.tb->access == ACCESS_PRIVATE)
4030     {
4031       gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4032                  " PRIVATE", proc->name, &where);
4033       return FAILURE;
4034     }
4035
4036   /* Compare the formal argument lists of both procedures.  This is also abused
4037      to find the position of the passed-object dummy arguments of both
4038      bindings as at least the overridden one might not yet be resolved and we
4039      need those positions in the check below.  */
4040   proc_pass_arg = old_pass_arg = 0;
4041   if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4042     proc_pass_arg = 1;
4043   if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4044     old_pass_arg = 1;
4045   argpos = 1;
4046   for (proc_formal = proc_target->formal, old_formal = old_target->formal;
4047        proc_formal && old_formal;
4048        proc_formal = proc_formal->next, old_formal = old_formal->next)
4049     {
4050       if (proc->n.tb->pass_arg
4051           && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4052         proc_pass_arg = argpos;
4053       if (old->n.tb->pass_arg
4054           && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4055         old_pass_arg = argpos;
4056
4057       /* Check that the names correspond.  */
4058       if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4059         {
4060           gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4061                      " to match the corresponding argument of the overridden"
4062                      " procedure", proc_formal->sym->name, proc->name, &where,
4063                      old_formal->sym->name);
4064           return FAILURE;
4065         }
4066
4067       check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4068       if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4069                                        check_type, err, sizeof(err)) == FAILURE)
4070         {
4071           gfc_error ("Argument mismatch for the overriding procedure "
4072                      "'%s' at %L: %s", proc->name, &where, err);
4073           return FAILURE;
4074         }
4075
4076       ++argpos;
4077     }
4078   if (proc_formal || old_formal)
4079     {
4080       gfc_error ("'%s' at %L must have the same number of formal arguments as"
4081                  " the overridden procedure", proc->name, &where);
4082       return FAILURE;
4083     }
4084
4085   /* If the overridden binding is NOPASS, the overriding one must also be
4086      NOPASS.  */
4087   if (old->n.tb->nopass && !proc->n.tb->nopass)
4088     {
4089       gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4090                  " NOPASS", proc->name, &where);
4091       return FAILURE;
4092     }
4093
4094   /* If the overridden binding is PASS(x), the overriding one must also be
4095      PASS and the passed-object dummy arguments must correspond.  */
4096   if (!old->n.tb->nopass)
4097     {
4098       if (proc->n.tb->nopass)
4099         {
4100           gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4101                      " PASS", proc->name, &where);
4102           return FAILURE;
4103         }
4104
4105       if (proc_pass_arg != old_pass_arg)
4106         {
4107           gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4108                      " the same position as the passed-object dummy argument of"
4109                      " the overridden procedure", proc->name, &where);
4110           return FAILURE;
4111         }
4112     }
4113
4114   return SUCCESS;
4115 }