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