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 &&
 991       (!compare_type_rank (s1, s2) || !compare_type_rank (s2, s1)))
 992     {
 993       if (errmsg != NULL)
 994         snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
 995                   s1->name);
 996       return FAILURE;
 997     }
 998
 999   /* Check INTENT.  */
1000   if (s1->attr.intent != s2->attr.intent)
1001     {
1002       snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1003                 s1->name);
1004       return FAILURE;
1005     }
1006
1007   /* Check OPTIONAL attribute.  */
1008   if (s1->attr.optional != s2->attr.optional)
1009     {
1010       snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1011                 s1->name);
1012       return FAILURE;
1013     }
1014
1015   /* Check ALLOCATABLE attribute.  */
1016   if (s1->attr.allocatable != s2->attr.allocatable)
1017     {
1018       snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1019                 s1->name);
1020       return FAILURE;
1021     }
1022
1023   /* Check POINTER attribute.  */
1024   if (s1->attr.pointer != s2->attr.pointer)
1025     {
1026       snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1027                 s1->name);
1028       return FAILURE;
1029     }
1030
1031   /* Check TARGET attribute.  */
1032   if (s1->attr.target != s2->attr.target)
1033     {
1034       snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1035                 s1->name);
1036       return FAILURE;
1037     }
1038
1039   /* FIXME: Do more comprehensive testing of attributes, like e.g.
1040             ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc.  */
1041
1042   /* Check string length.  */
1043   if (s1->ts.type == BT_CHARACTER
1044       && s1->ts.u.cl && s1->ts.u.cl->length
1045       && s2->ts.u.cl && s2->ts.u.cl->length)
1046     {
1047       int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1048                                           s2->ts.u.cl->length);
1049       switch (compval)
1050       {
1051         case -1:
1052         case  1:
1053         case -3:
1054           snprintf (errmsg, err_len, "Character length mismatch "
1055                     "in argument '%s'", s1->name);
1056           return FAILURE;
1057
1058         case -2:
1059           /* FIXME: Implement a warning for this case.
1060           gfc_warning ("Possible character length mismatch in argument '%s'",
1061                        s1->name);*/
1062           break;
1063
1064         case 0:
1065           break;
1066
1067         default:
1068           gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1069                               "%i of gfc_dep_compare_expr", compval);
1070           break;
1071       }
1072     }
1073
1074   /* Check array shape.  */
1075   if (s1->as && s2->as)
1076     {
1077       int i, compval;
1078       gfc_expr *shape1, *shape2;
1079
1080       if (s1->as->type != s2->as->type)
1081         {
1082           snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1083                     s1->name);
1084           return FAILURE;
1085         }
1086
1087       if (s1->as->type == AS_EXPLICIT)
1088         for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1089           {
1090             shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1091                                   gfc_copy_expr (s1->as->lower[i]));
1092             shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1093                                   gfc_copy_expr (s2->as->lower[i]));
1094             compval = gfc_dep_compare_expr (shape1, shape2);
1095             gfc_free_expr (shape1);
1096             gfc_free_expr (shape2);
1097             switch (compval)
1098             {
1099               case -1:
1100               case  1:
1101               case -3:
1102                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1103                           "argument '%s'", i + 1, s1->name);
1104                 return FAILURE;
1105
1106               case -2:
1107                 /* FIXME: Implement a warning for this case.
1108                 gfc_warning ("Possible shape mismatch in argument '%s'",
1109                             s1->name);*/
1110                 break;
1111
1112               case 0:
1113                 break;
1114
1115               default:
1116                 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1117                                     "result %i of gfc_dep_compare_expr",
1118                                     compval);
1119                 break;
1120             }
1121           }
1122     }
1123
1124   return SUCCESS;
1125 }
1126
1127
1128 /* 'Compare' two formal interfaces associated with a pair of symbols.
1129    We return nonzero if there exists an actual argument list that
1130    would be ambiguous between the two interfaces, zero otherwise.
1131    'strict_flag' specifies whether all the characteristics are
1132    required to match, which is not the case for ambiguity checks.*/
1133
1134 int
1135 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1136                         int generic_flag, int strict_flag,
1137                         char *errmsg, int err_len)
1138 {
1139   gfc_formal_arglist *f1, *f2;
1140
1141   gcc_assert (name2 != NULL);
1142
1143   if (s1->attr.function && (s2->attr.subroutine
1144       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1145           && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1146     {
1147       if (errmsg != NULL)
1148         snprintf (errmsg, err_len, "'%s' is not a function", name2);
1149       return 0;
1150     }
1151
1152   if (s1->attr.subroutine && s2->attr.function)
1153     {
1154       if (errmsg != NULL)
1155         snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1156       return 0;
1157     }
1158
1159   /* Do strict checks on all characteristics
1160      (for dummy procedures and procedure pointer assignments).  */
1161   if (!generic_flag && strict_flag)
1162     {
1163       if (s1->attr.function && s2->attr.function)
1164         {
1165           /* If both are functions, check result type.  */
1166           if (s1->ts.type == BT_UNKNOWN)
1167             return 1;
1168           if (!compare_type_rank (s1,s2))
1169             {
1170               if (errmsg != NULL)
1171                 snprintf (errmsg, err_len, "Type/rank mismatch in return value "
1172                           "of '%s'", name2);
1173               return 0;
1174             }
1175
1176           /* FIXME: Check array bounds and string length of result.  */
1177         }
1178
1179       if (s1->attr.pure && !s2->attr.pure)
1180         {
1181           snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1182           return 0;
1183         }
1184       if (s1->attr.elemental && !s2->attr.elemental)
1185         {
1186           snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1187           return 0;
1188         }
1189     }
1190
1191   if (s1->attr.if_source == IFSRC_UNKNOWN
1192       || s2->attr.if_source == IFSRC_UNKNOWN)
1193     return 1;
1194
1195   f1 = s1->formal;
1196   f2 = s2->formal;
1197
1198   if (f1 == NULL && f2 == NULL)
1199     return 1;                   /* Special case: No arguments.  */
1200
1201   if (generic_flag)
1202     {
1203       if (count_types_test (f1, f2) || count_types_test (f2, f1))
1204         return 0;
1205       if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1206         return 0;
1207     }
1208   else
1209     /* Perform the abbreviated correspondence test for operators (the
1210        arguments cannot be optional and are always ordered correctly).
1211        This is also done when comparing interfaces for dummy procedures and in
1212        procedure pointer assignments.  */
1213
1214     for (;;)
1215       {
1216         /* Check existence.  */
1217         if (f1 == NULL && f2 == NULL)
1218           break;
1219         if (f1 == NULL || f2 == NULL)
1220           {
1221             if (errmsg != NULL)
1222               snprintf (errmsg, err_len, "'%s' has the wrong number of "
1223                         "arguments", name2);
1224             return 0;
1225           }
1226
1227         if (strict_flag)
1228           {
1229             /* Check all characteristics.  */
1230             if (check_dummy_characteristics (f1->sym, f2->sym,
1231                                              true, errmsg, err_len) == FAILURE)
1232               return 0;
1233           }
1234         else if (!compare_type_rank (f2->sym, f1->sym))
1235           {
1236             /* Only check type and rank.  */
1237             if (errmsg != NULL)
1238               snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1239                         f1->sym->name);
1240             return 0;
1241           }
1242
1243         f1 = f1->next;
1244         f2 = f2->next;
1245       }
1246
1247   return 1;
1248 }
1249
1250
1251 /* Given a pointer to an interface pointer, remove duplicate
1252    interfaces and make sure that all symbols are either functions
1253    or subroutines, and all of the same kind.  Returns nonzero if
1254    something goes wrong.  */
1255
1256 static int
1257 check_interface0 (gfc_interface *p, const char *interface_name)
1258 {
1259   gfc_interface *psave, *q, *qlast;
1260
1261   psave = p;
1262   for (; p; p = p->next)
1263     {
1264       /* Make sure all symbols in the interface have been defined as
1265          functions or subroutines.  */
1266       if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1267            || !p->sym->attr.if_source)
1268           && p->sym->attr.flavor != FL_DERIVED)
1269         {
1270           if (p->sym->attr.external)
1271             gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1272                        p->sym->name, interface_name, &p->sym->declared_at);
1273           else
1274             gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1275                        "subroutine", p->sym->name, interface_name,
1276                       &p->sym->declared_at);
1277           return 1;
1278         }
1279
1280       /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
1281       if ((psave->sym->attr.function && !p->sym->attr.function
1282            && p->sym->attr.flavor != FL_DERIVED)
1283           || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1284         {
1285           if (p->sym->attr.flavor != FL_DERIVED)
1286             gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1287                        " or all FUNCTIONs", interface_name,
1288                        &p->sym->declared_at);
1289           else
1290             gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1291                        "generic name is also the name of a derived type",
1292                        interface_name, &p->sym->declared_at);
1293           return 1;
1294         }
1295
1296       /* F2003, C1207. F2008, C1207.  */
1297       if (p->sym->attr.proc == PROC_INTERNAL
1298           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Internal procedure "
1299                              "'%s' in %s at %L", p->sym->name, interface_name,
1300                              &p->sym->declared_at) == FAILURE)
1301         return 1;
1302     }
1303   p = psave;
1304
1305   /* Remove duplicate interfaces in this interface list.  */
1306   for (; p; p = p->next)
1307     {
1308       qlast = p;
1309
1310       for (q = p->next; q;)
1311         {
1312           if (p->sym != q->sym)
1313             {
1314               qlast = q;
1315               q = q->next;
1316             }
1317           else
1318             {
1319               /* Duplicate interface.  */
1320               qlast->next = q->next;
1321               free (q);
1322               q = qlast->next;
1323             }
1324         }
1325     }
1326
1327   return 0;
1328 }
1329
1330
1331 /* Check lists of interfaces to make sure that no two interfaces are
1332    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
1333
1334 static int
1335 check_interface1 (gfc_interface *p, gfc_interface *q0,
1336                   int generic_flag, const char *interface_name,
1337                   bool referenced)
1338 {
1339   gfc_interface *q;
1340   for (; p; p = p->next)
1341     for (q = q0; q; q = q->next)
1342       {
1343         if (p->sym == q->sym)
1344           continue;             /* Duplicates OK here.  */
1345
1346         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1347           continue;
1348
1349         if (p->sym->attr.flavor != FL_DERIVED
1350             && q->sym->attr.flavor != FL_DERIVED
1351             && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1352                                        generic_flag, 0, NULL, 0))
1353           {
1354             if (referenced)
1355               gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1356                          p->sym->name, q->sym->name, interface_name,
1357                          &p->where);
1358             else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1359               gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1360                            p->sym->name, q->sym->name, interface_name,
1361                            &p->where);
1362             else
1363               gfc_warning ("Although not referenced, '%s' has ambiguous "
1364                            "interfaces at %L", interface_name, &p->where);
1365             return 1;
1366           }
1367       }
1368   return 0;
1369 }
1370
1371
1372 /* Check the generic and operator interfaces of symbols to make sure
1373    that none of the interfaces conflict.  The check has to be done
1374    after all of the symbols are actually loaded.  */
1375
1376 static void
1377 check_sym_interfaces (gfc_symbol *sym)
1378 {
1379   char interface_name[100];
1380   gfc_interface *p;
1381
1382   if (sym->ns != gfc_current_ns)
1383     return;
1384
1385   if (sym->generic != NULL)
1386     {
1387       sprintf (interface_name, "generic interface '%s'", sym->name);
1388       if (check_interface0 (sym->generic, interface_name))
1389         return;
1390
1391       for (p = sym->generic; p; p = p->next)
1392         {
1393           if (p->sym->attr.mod_proc
1394               && (p->sym->attr.if_source != IFSRC_DECL
1395                   || p->sym->attr.procedure))
1396             {
1397               gfc_error ("'%s' at %L is not a module procedure",
1398                          p->sym->name, &p->where);
1399               return;
1400             }
1401         }
1402
1403       /* Originally, this test was applied to host interfaces too;
1404          this is incorrect since host associated symbols, from any
1405          source, cannot be ambiguous with local symbols.  */
1406       check_interface1 (sym->generic, sym->generic, 1, interface_name,
1407                         sym->attr.referenced || !sym->attr.use_assoc);
1408     }
1409 }
1410
1411
1412 static void
1413 check_uop_interfaces (gfc_user_op *uop)
1414 {
1415   char interface_name[100];
1416   gfc_user_op *uop2;
1417   gfc_namespace *ns;
1418
1419   sprintf (interface_name, "operator interface '%s'", uop->name);
1420   if (check_interface0 (uop->op, interface_name))
1421     return;
1422
1423   for (ns = gfc_current_ns; ns; ns = ns->parent)
1424     {
1425       uop2 = gfc_find_uop (uop->name, ns);
1426       if (uop2 == NULL)
1427         continue;
1428
1429       check_interface1 (uop->op, uop2->op, 0,
1430                         interface_name, true);
1431     }
1432 }
1433
1434 /* Given an intrinsic op, return an equivalent op if one exists,
1435    or INTRINSIC_NONE otherwise.  */
1436
1437 gfc_intrinsic_op
1438 gfc_equivalent_op (gfc_intrinsic_op op)
1439 {
1440   switch(op)
1441     {
1442     case INTRINSIC_EQ:
1443       return INTRINSIC_EQ_OS;
1444
1445     case INTRINSIC_EQ_OS:
1446       return INTRINSIC_EQ;
1447
1448     case INTRINSIC_NE:
1449       return INTRINSIC_NE_OS;
1450
1451     case INTRINSIC_NE_OS:
1452       return INTRINSIC_NE;
1453
1454     case INTRINSIC_GT:
1455       return INTRINSIC_GT_OS;
1456
1457     case INTRINSIC_GT_OS:
1458       return INTRINSIC_GT;
1459
1460     case INTRINSIC_GE:
1461       return INTRINSIC_GE_OS;
1462
1463     case INTRINSIC_GE_OS:
1464       return INTRINSIC_GE;
1465
1466     case INTRINSIC_LT:
1467       return INTRINSIC_LT_OS;
1468
1469     case INTRINSIC_LT_OS:
1470       return INTRINSIC_LT;
1471
1472     case INTRINSIC_LE:
1473       return INTRINSIC_LE_OS;
1474
1475     case INTRINSIC_LE_OS:
1476       return INTRINSIC_LE;
1477
1478     default:
1479       return INTRINSIC_NONE;
1480     }
1481 }
1482
1483 /* For the namespace, check generic, user operator and intrinsic
1484    operator interfaces for consistency and to remove duplicate
1485    interfaces.  We traverse the whole namespace, counting on the fact
1486    that most symbols will not have generic or operator interfaces.  */
1487
1488 void
1489 gfc_check_interfaces (gfc_namespace *ns)
1490 {
1491   gfc_namespace *old_ns, *ns2;
1492   char interface_name[100];
1493   int i;
1494
1495   old_ns = gfc_current_ns;
1496   gfc_current_ns = ns;
1497
1498   gfc_traverse_ns (ns, check_sym_interfaces);
1499
1500   gfc_traverse_user_op (ns, check_uop_interfaces);
1501
1502   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1503     {
1504       if (i == INTRINSIC_USER)
1505         continue;
1506
1507       if (i == INTRINSIC_ASSIGN)
1508         strcpy (interface_name, "intrinsic assignment operator");
1509       else
1510         sprintf (interface_name, "intrinsic '%s' operator",
1511                  gfc_op2string ((gfc_intrinsic_op) i));
1512
1513       if (check_interface0 (ns->op[i], interface_name))
1514         continue;
1515
1516       if (ns->op[i])
1517         gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1518                                       ns->op[i]->where);
1519
1520       for (ns2 = ns; ns2; ns2 = ns2->parent)
1521         {
1522           gfc_intrinsic_op other_op;
1523
1524           if (check_interface1 (ns->op[i], ns2->op[i], 0,
1525                                 interface_name, true))
1526             goto done;
1527
1528           /* i should be gfc_intrinsic_op, but has to be int with this cast
1529              here for stupid C++ compatibility rules.  */
1530           other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1531           if (other_op != INTRINSIC_NONE
1532             &&  check_interface1 (ns->op[i], ns2->op[other_op],
1533                                   0, interface_name, true))
1534             goto done;
1535         }
1536     }
1537
1538 done:
1539   gfc_current_ns = old_ns;
1540 }
1541
1542
1543 static int
1544 symbol_rank (gfc_symbol *sym)
1545 {
1546   if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1547     return CLASS_DATA (sym)->as->rank;
1548
1549   return (sym->as == NULL) ? 0 : sym->as->rank;
1550 }
1551
1552
1553 /* Given a symbol of a formal argument list and an expression, if the
1554    formal argument is allocatable, check that the actual argument is
1555    allocatable. Returns nonzero if compatible, zero if not compatible.  */
1556
1557 static int
1558 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1559 {
1560   symbol_attribute attr;
1561
1562   if (formal->attr.allocatable
1563       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1564     {
1565       attr = gfc_expr_attr (actual);
1566       if (!attr.allocatable)
1567         return 0;
1568     }
1569
1570   return 1;
1571 }
1572
1573
1574 /* Given a symbol of a formal argument list and an expression, if the
1575    formal argument is a pointer, see if the actual argument is a
1576    pointer. Returns nonzero if compatible, zero if not compatible.  */
1577
1578 static int
1579 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1580 {
1581   symbol_attribute attr;
1582
1583   if (formal->attr.pointer)
1584     {
1585       attr = gfc_expr_attr (actual);
1586
1587       /* Fortran 2008 allows non-pointer actual arguments.  */
1588       if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1589         return 2;
1590
1591       if (!attr.pointer)
1592         return 0;
1593     }
1594
1595   return 1;
1596 }
1597
1598
1599 /* Emit clear error messages for rank mismatch.  */
1600
1601 static void
1602 argument_rank_mismatch (const char *name, locus *where,
1603                         int rank1, int rank2)
1604 {
1605   if (rank1 == 0)
1606     {
1607       gfc_error ("Rank mismatch in argument '%s' at %L "
1608                  "(scalar and rank-%d)", name, where, rank2);
1609     }
1610   else if (rank2 == 0)
1611     {
1612       gfc_error ("Rank mismatch in argument '%s' at %L "
1613                  "(rank-%d and scalar)", name, where, rank1);
1614     }
1615   else
1616     {
1617       gfc_error ("Rank mismatch in argument '%s' at %L "
1618                  "(rank-%d and rank-%d)", name, where, rank1, rank2);
1619     }
1620 }
1621
1622
1623 /* Given a symbol of a formal argument list and an expression, see if
1624    the two are compatible as arguments.  Returns nonzero if
1625    compatible, zero if not compatible.  */
1626
1627 static int
1628 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1629                    int ranks_must_agree, int is_elemental, locus *where)
1630 {
1631   gfc_ref *ref;
1632   bool rank_check, is_pointer;
1633
1634   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1635      procs c_f_pointer or c_f_procpointer, and we need to accept most
1636      pointers the user could give us.  This should allow that.  */
1637   if (formal->ts.type == BT_VOID)
1638     return 1;
1639
1640   if (formal->ts.type == BT_DERIVED
1641       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1642       && actual->ts.type == BT_DERIVED
1643       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1644     return 1;
1645
1646   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1647     /* Make sure the vtab symbol is present when
1648        the module variables are generated.  */
1649     gfc_find_derived_vtab (actual->ts.u.derived);
1650
1651   if (actual->ts.type == BT_PROCEDURE)
1652     {
1653       char err[200];
1654       gfc_symbol *act_sym = actual->symtree->n.sym;
1655
1656       if (formal->attr.flavor != FL_PROCEDURE)
1657         {
1658           if (where)
1659             gfc_error ("Invalid procedure argument at %L", &actual->where);
1660           return 0;
1661         }
1662
1663       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1664                                    sizeof(err)))
1665         {
1666           if (where)
1667             gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1668                        formal->name, &actual->where, err);
1669           return 0;
1670         }
1671
1672       if (formal->attr.function && !act_sym->attr.function)
1673         {
1674           gfc_add_function (&act_sym->attr, act_sym->name,
1675           &act_sym->declared_at);
1676           if (act_sym->ts.type == BT_UNKNOWN
1677               && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1678             return 0;
1679         }
1680       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1681         gfc_add_subroutine (&act_sym->attr, act_sym->name,
1682                             &act_sym->declared_at);
1683
1684       return 1;
1685     }
1686
1687   /* F2008, C1241.  */
1688   if (formal->attr.pointer && formal->attr.contiguous
1689       && !gfc_is_simply_contiguous (actual, true))
1690     {
1691       if (where)
1692         gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1693                    "must be simply contigous", formal->name, &actual->where);
1694       return 0;
1695     }
1696
1697   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1698       && actual->ts.type != BT_HOLLERITH
1699       && !gfc_compare_types (&formal->ts, &actual->ts)
1700       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
1701            && gfc_compare_derived_types (formal->ts.u.derived,
1702                                          CLASS_DATA (actual)->ts.u.derived)))
1703     {
1704       if (where)
1705         gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1706                    formal->name, &actual->where, gfc_typename (&actual->ts),
1707                    gfc_typename (&formal->ts));
1708       return 0;
1709     }
1710
1711   /* F2008, 12.5.2.5.  */
1712   if (formal->ts.type == BT_CLASS
1713       && (CLASS_DATA (formal)->attr.class_pointer
1714           || CLASS_DATA (formal)->attr.allocatable))
1715     {
1716       if (actual->ts.type != BT_CLASS)
1717         {
1718           if (where)
1719             gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1720                         formal->name, &actual->where);
1721           return 0;
1722         }
1723       if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
1724                                       CLASS_DATA (formal)->ts.u.derived))
1725         {
1726           if (where)
1727             gfc_error ("Actual argument to '%s' at %L must have the same "
1728                        "declared type", formal->name, &actual->where);
1729           return 0;
1730         }
1731     }
1732
1733   if (formal->attr.codimension && !gfc_is_coarray (actual))
1734     {
1735       if (where)
1736         gfc_error ("Actual argument to '%s' at %L must be a coarray",
1737                        formal->name, &actual->where);
1738       return 0;
1739     }
1740
1741   if (formal->attr.codimension && formal->attr.allocatable)
1742     {
1743       gfc_ref *last = NULL;
1744
1745       for (ref = actual->ref; ref; ref = ref->next)
1746         if (ref->type == REF_COMPONENT)
1747           last = ref;
1748
1749       /* F2008, 12.5.2.6.  */
1750       if ((last && last->u.c.component->as->corank != formal->as->corank)
1751           || (!last
1752               && actual->symtree->n.sym->as->corank != formal->as->corank))
1753         {
1754           if (where)
1755             gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1756                    formal->name, &actual->where, formal->as->corank,
1757                    last ? last->u.c.component->as->corank
1758                         : actual->symtree->n.sym->as->corank);
1759           return 0;
1760         }
1761     }
1762
1763   if (formal->attr.codimension)
1764     {
1765       /* F2008, 12.5.2.8.  */
1766       if (formal->attr.dimension
1767           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1768           && gfc_expr_attr (actual).dimension
1769           && !gfc_is_simply_contiguous (actual, true))
1770         {
1771           if (where)
1772             gfc_error ("Actual argument to '%s' at %L must be simply "
1773                        "contiguous", formal->name, &actual->where);
1774           return 0;
1775         }
1776
1777       /* F2008, C1303 and C1304.  */
1778       if (formal->attr.intent != INTENT_INOUT
1779           && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1780                && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1781                && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1782               || formal->attr.lock_comp))
1783
1784         {
1785           if (where)
1786             gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1787                        "which is LOCK_TYPE or has a LOCK_TYPE component",
1788                        formal->name, &actual->where);
1789           return 0;
1790         }
1791     }
1792
1793   /* F2008, C1239/C1240.  */
1794   if (actual->expr_type == EXPR_VARIABLE
1795       && (actual->symtree->n.sym->attr.asynchronous
1796          || actual->symtree->n.sym->attr.volatile_)
1797       &&  (formal->attr.asynchronous || formal->attr.volatile_)
1798       && actual->rank && !gfc_is_simply_contiguous (actual, true)
1799       && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1800           || formal->attr.contiguous))
1801     {
1802       if (where)
1803         gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1804                    "array without CONTIGUOUS attribute - as actual argument at"
1805                    " %L is not simply contiguous and both are ASYNCHRONOUS "
1806                    "or VOLATILE", formal->name, &actual->where);
1807       return 0;
1808     }
1809
1810   if (formal->attr.allocatable && !formal->attr.codimension
1811       && gfc_expr_attr (actual).codimension)
1812     {
1813       if (formal->attr.intent == INTENT_OUT)
1814         {
1815           if (where)
1816             gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1817                        "INTENT(OUT) dummy argument '%s'", &actual->where,
1818                        formal->name);
1819             return 0;
1820         }
1821       else if (gfc_option.warn_surprising && where
1822                && formal->attr.intent != INTENT_IN)
1823         gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1824                      "argument '%s', which is invalid if the allocation status"
1825                      " is modified",  &actual->where, formal->name);
1826     }
1827
1828   if (symbol_rank (formal) == actual->rank)
1829     return 1;
1830
1831   if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
1832         && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
1833     return 1;
1834
1835   rank_check = where != NULL && !is_elemental && formal->as
1836                && (formal->as->type == AS_ASSUMED_SHAPE
1837                    || formal->as->type == AS_DEFERRED)
1838                && actual->expr_type != EXPR_NULL;
1839
1840   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
1841   if (rank_check || ranks_must_agree
1842       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1843       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1844       || (actual->rank == 0
1845           && ((formal->ts.type == BT_CLASS
1846                && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
1847               || (formal->ts.type != BT_CLASS
1848                    && formal->as->type == AS_ASSUMED_SHAPE))
1849           && actual->expr_type != EXPR_NULL)
1850       || (actual->rank == 0 && formal->attr.dimension
1851           && gfc_is_coindexed (actual)))
1852     {
1853       if (where)
1854         argument_rank_mismatch (formal->name, &actual->where,
1855                                 symbol_rank (formal), actual->rank);
1856       return 0;
1857     }
1858   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1859     return 1;
1860
1861   /* At this point, we are considering a scalar passed to an array.   This
1862      is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1863      - if the actual argument is (a substring of) an element of a
1864        non-assumed-shape/non-pointer/non-polymorphic array; or
1865      - (F2003) if the actual argument is of type character of default/c_char
1866        kind.  */
1867
1868   is_pointer = actual->expr_type == EXPR_VARIABLE
1869                ? actual->symtree->n.sym->attr.pointer : false;
1870
1871   for (ref = actual->ref; ref; ref = ref->next)
1872     {
1873       if (ref->type == REF_COMPONENT)
1874         is_pointer = ref->u.c.component->attr.pointer;
1875       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1876                && ref->u.ar.dimen > 0
1877                && (!ref->next
1878                    || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
1879         break;
1880     }
1881
1882   if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
1883     {
1884       if (where)
1885         gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1886                    "at %L", formal->name, &actual->where);
1887       return 0;
1888     }
1889
1890   if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
1891       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1892     {
1893       if (where)
1894         gfc_error ("Element of assumed-shaped or pointer "
1895                    "array passed to array dummy argument '%s' at %L",
1896                    formal->name, &actual->where);
1897       return 0;
1898     }
1899
1900   if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
1901       && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1902     {
1903       if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
1904         {
1905           if (where)
1906             gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1907                        "CHARACTER actual argument with array dummy argument "
1908                        "'%s' at %L", formal->name, &actual->where);
1909           return 0;
1910         }
1911
1912       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1913         {
1914           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1915                      "array dummy argument '%s' at %L",
1916                      formal->name, &actual->where);
1917           return 0;
1918         }
1919       else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1920         return 0;
1921       else
1922         return 1;
1923     }
1924
1925   if (ref == NULL && actual->expr_type != EXPR_NULL)
1926     {
1927       if (where)
1928         argument_rank_mismatch (formal->name, &actual->where,
1929                                 symbol_rank (formal), actual->rank);
1930       return 0;
1931     }
1932
1933   return 1;
1934 }
1935
1936
1937 /* Returns the storage size of a symbol (formal argument) or
1938    zero if it cannot be determined.  */
1939
1940 static unsigned long
1941 get_sym_storage_size (gfc_symbol *sym)
1942 {
1943   int i;
1944   unsigned long strlen, elements;
1945
1946   if (sym->ts.type == BT_CHARACTER)
1947     {
1948       if (sym->ts.u.cl && sym->ts.u.cl->length
1949           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1950         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1951       else
1952         return 0;
1953     }
1954   else
1955     strlen = 1;
1956
1957   if (symbol_rank (sym) == 0)
1958     return strlen;
1959
1960   elements = 1;
1961   if (sym->as->type != AS_EXPLICIT)
1962     return 0;
1963   for (i = 0; i < sym->as->rank; i++)
1964     {
1965       if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1966           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1967         return 0;
1968
1969       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
1970                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
1971     }
1972
1973   return strlen*elements;
1974 }
1975
1976
1977 /* Returns the storage size of an expression (actual argument) or
1978    zero if it cannot be determined. For an array element, it returns
1979    the remaining size as the element sequence consists of all storage
1980    units of the actual argument up to the end of the array.  */
1981
1982 static unsigned long
1983 get_expr_storage_size (gfc_expr *e)
1984 {
1985   int i;
1986   long int strlen, elements;
1987   long int substrlen = 0;
1988   bool is_str_storage = false;
1989   gfc_ref *ref;
1990
1991   if (e == NULL)
1992     return 0;
1993
1994   if (e->ts.type == BT_CHARACTER)
1995     {
1996       if (e->ts.u.cl && e->ts.u.cl->length
1997           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1998         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1999       else if (e->expr_type == EXPR_CONSTANT
2000                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2001         strlen = e->value.character.length;
2002       else
2003         return 0;
2004     }
2005   else
2006     strlen = 1; /* Length per element.  */
2007
2008   if (e->rank == 0 && !e->ref)
2009     return strlen;
2010
2011   elements = 1;
2012   if (!e->ref)
2013     {
2014       if (!e->shape)
2015         return 0;
2016       for (i = 0; i < e->rank; i++)
2017         elements *= mpz_get_si (e->shape[i]);
2018       return elements*strlen;
2019     }
2020
2021   for (ref = e->ref; ref; ref = ref->next)
2022     {
2023       if (ref->type == REF_SUBSTRING && ref->u.ss.start
2024           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2025         {
2026           if (is_str_storage)
2027             {
2028               /* The string length is the substring length.
2029                  Set now to full string length.  */
2030               if (!ref->u.ss.length || !ref->u.ss.length->length
2031                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2032                 return 0;
2033
2034               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2035             }
2036           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2037           continue;
2038         }
2039
2040       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
2041           && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
2042           && ref->u.ar.as->upper)
2043         for (i = 0; i < ref->u.ar.dimen; i++)
2044           {
2045             long int start, end, stride;
2046             stride = 1;
2047
2048             if (ref->u.ar.stride[i])
2049               {
2050                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2051                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2052                 else
2053                   return 0;
2054               }
2055
2056             if (ref->u.ar.start[i])
2057               {
2058                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2059                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2060                 else
2061                   return 0;
2062               }
2063             else if (ref->u.ar.as->lower[i]
2064                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2065               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2066             else
2067               return 0;
2068
2069             if (ref->u.ar.end[i])
2070               {
2071                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2072                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2073                 else
2074                   return 0;
2075               }
2076             else if (ref->u.ar.as->upper[i]
2077                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2078               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2079             else
2080               return 0;
2081
2082             elements *= (end - start)/stride + 1L;
2083           }
2084       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
2085                && ref->u.ar.as->lower && ref->u.ar.as->upper)
2086         for (i = 0; i < ref->u.ar.as->rank; i++)
2087           {
2088             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2089                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2090                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2091               elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2092                           - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2093                           + 1L;
2094             else
2095               return 0;
2096           }
2097       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2098                && e->expr_type == EXPR_VARIABLE)
2099         {
2100           if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2101               || e->symtree->n.sym->attr.pointer)
2102             {
2103               elements = 1;
2104               continue;
2105             }
2106
2107           /* Determine the number of remaining elements in the element
2108              sequence for array element designators.  */
2109           is_str_storage = true;
2110           for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2111             {
2112               if (ref->u.ar.start[i] == NULL
2113                   || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2114                   || ref->u.ar.as->upper[i] == NULL
2115                   || ref->u.ar.as->lower[i] == NULL
2116                   || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2117                   || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2118                 return 0;
2119
2120               elements
2121                    = elements
2122                      * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2123                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2124                         + 1L)
2125                      - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2126                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2127             }
2128         }
2129     }
2130
2131   if (substrlen)
2132     return (is_str_storage) ? substrlen + (elements-1)*strlen
2133                             : elements*strlen;
2134   else
2135     return elements*strlen;
2136 }
2137
2138
2139 /* Given an expression, check whether it is an array section
2140    which has a vector subscript. If it has, one is returned,
2141    otherwise zero.  */
2142
2143 int
2144 gfc_has_vector_subscript (gfc_expr *e)
2145 {
2146   int i;
2147   gfc_ref *ref;
2148
2149   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2150     return 0;
2151
2152   for (ref = e->ref; ref; ref = ref->next)
2153     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2154       for (i = 0; i < ref->u.ar.dimen; i++)
2155         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2156           return 1;
2157
2158   return 0;
2159 }
2160
2161
2162 /* Given formal and actual argument lists, see if they are compatible.
2163    If they are compatible, the actual argument list is sorted to
2164    correspond with the formal list, and elements for missing optional
2165    arguments are inserted. If WHERE pointer is nonnull, then we issue
2166    errors when things don't match instead of just returning the status
2167    code.  */
2168
2169 static int
2170 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2171                        int ranks_must_agree, int is_elemental, locus *where)
2172 {
2173   gfc_actual_arglist **new_arg, *a, *actual, temp;
2174   gfc_formal_arglist *f;
2175   int i, n, na;
2176   unsigned long actual_size, formal_size;
2177   bool full_array = false;
2178
2179   actual = *ap;
2180
2181   if (actual == NULL && formal == NULL)
2182     return 1;
2183
2184   n = 0;
2185   for (f = formal; f; f = f->next)
2186     n++;
2187
2188   new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2189
2190   for (i = 0; i < n; i++)
2191     new_arg[i] = NULL;
2192
2193   na = 0;
2194   f = formal;
2195   i = 0;
2196
2197   for (a = actual; a; a = a->next, f = f->next)
2198     {
2199       /* Look for keywords but ignore g77 extensions like %VAL.  */
2200       if (a->name != NULL && a->name[0] != '%')
2201         {
2202           i = 0;
2203           for (f = formal; f; f = f->next, i++)
2204             {
2205               if (f->sym == NULL)
2206                 continue;
2207               if (strcmp (f->sym->name, a->name) == 0)
2208                 break;
2209             }
2210
2211           if (f == NULL)
2212             {
2213               if (where)
2214                 gfc_error ("Keyword argument '%s' at %L is not in "
2215                            "the procedure", a->name, &a->expr->where);
2216               return 0;
2217             }
2218
2219           if (new_arg[i] != NULL)
2220             {
2221               if (where)
2222                 gfc_error ("Keyword argument '%s' at %L is already associated "
2223                            "with another actual argument", a->name,
2224                            &a->expr->where);
2225               return 0;
2226             }
2227         }
2228
2229       if (f == NULL)
2230         {
2231           if (where)
2232             gfc_error ("More actual than formal arguments in procedure "
2233                        "call at %L", where);
2234
2235           return 0;
2236         }
2237
2238       if (f->sym == NULL && a->expr == NULL)
2239         goto match;
2240
2241       if (f->sym == NULL)
2242         {
2243           if (where)
2244             gfc_error ("Missing alternate return spec in subroutine call "
2245                        "at %L", where);
2246           return 0;
2247         }
2248
2249       if (a->expr == NULL)
2250         {
2251           if (where)
2252             gfc_error ("Unexpected alternate return spec in subroutine "
2253                        "call at %L", where);
2254           return 0;
2255         }
2256
2257       if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
2258           && (f->sym->attr.allocatable || !f->sym->attr.optional
2259               || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2260         {
2261           if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
2262             gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2263                        where, f->sym->name);
2264           else if (where)
2265             gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2266                        "dummy '%s'", where, f->sym->name);
2267
2268           return 0;
2269         }
2270
2271       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2272                               is_elemental, where))
2273         return 0;
2274
2275       /* Special case for character arguments.  For allocatable, pointer
2276          and assumed-shape dummies, the string length needs to match
2277          exactly.  */
2278       if (a->expr->ts.type == BT_CHARACTER
2279            && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2280            && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2281            && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2282            && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2283            && (f->sym->attr.pointer || f->sym->attr.allocatable
2284                || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2285            && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2286                         f->sym->ts.u.cl->length->value.integer) != 0))
2287          {
2288            if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2289              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2290                           "argument and pointer or allocatable dummy argument "
2291                           "'%s' at %L",
2292                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2293                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2294                           f->sym->name, &a->expr->where);
2295            else if (where)
2296              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2297                           "argument and assumed-shape dummy argument '%s' "
2298                           "at %L",
2299                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2300                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2301                           f->sym->name, &a->expr->where);
2302            return 0;
2303          }
2304
2305       if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2306             && f->sym->ts.deferred != a->expr->ts.deferred
2307             && a->expr->ts.type == BT_CHARACTER)
2308         {
2309           if (where)
2310             gfc_error ("Actual argument at %L to allocatable or "
2311                        "pointer dummy argument '%s' must have a deferred "
2312                        "length type parameter if and only if the dummy has one",
2313                        &a->expr->where, f->sym->name);
2314           return 0;
2315         }
2316
2317       if (f->sym->ts.type == BT_CLASS)
2318         goto skip_size_check;
2319
2320       actual_size = get_expr_storage_size (a->expr);
2321       formal_size = get_sym_storage_size (f->sym);
2322       if (actual_size != 0 && actual_size < formal_size
2323           && a->expr->ts.type != BT_PROCEDURE
2324           && f->sym->attr.flavor != FL_PROCEDURE)
2325         {
2326           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2327             gfc_warning ("Character length of actual argument shorter "
2328                          "than of dummy argument '%s' (%lu/%lu) at %L",
2329                          f->sym->name, actual_size, formal_size,
2330                          &a->expr->where);
2331           else if (where)
2332             gfc_warning ("Actual argument contains too few "
2333                          "elements for dummy argument '%s' (%lu/%lu) at %L",
2334                          f->sym->name, actual_size, formal_size,
2335                          &a->expr->where);
2336           return  0;
2337         }
2338
2339      skip_size_check:
2340
2341       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2342          is provided for a procedure pointer formal argument.  */
2343       if (f->sym->attr.proc_pointer
2344           && !((a->expr->expr_type == EXPR_VARIABLE
2345                 && a->expr->symtree->n.sym->attr.proc_pointer)
2346                || (a->expr->expr_type == EXPR_FUNCTION
2347                    && a->expr->symtree->n.sym->result->attr.proc_pointer)
2348                || gfc_is_proc_ptr_comp (a->expr, NULL)))
2349         {
2350           if (where)
2351             gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2352                        f->sym->name, &a->expr->where);
2353           return 0;
2354         }
2355
2356       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2357          provided for a procedure formal argument.  */
2358       if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2359           && a->expr->expr_type == EXPR_VARIABLE
2360           && f->sym->attr.flavor == FL_PROCEDURE)
2361         {
2362           if (where)
2363             gfc_error ("Expected a procedure for argument '%s' at %L",
2364                        f->sym->name, &a->expr->where);
2365           return 0;
2366         }
2367
2368       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2369           && a->expr->expr_type == EXPR_VARIABLE
2370           && a->expr->symtree->n.sym->as
2371           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2372           && (a->expr->ref == NULL
2373               || (a->expr->ref->type == REF_ARRAY
2374                   && a->expr->ref->u.ar.type == AR_FULL)))
2375         {
2376           if (where)
2377             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2378                        " array at %L", f->sym->name, where);
2379           return 0;
2380         }
2381
2382       if (a->expr->expr_type != EXPR_NULL
2383           && compare_pointer (f->sym, a->expr) == 0)
2384         {
2385           if (where)
2386             gfc_error ("Actual argument for '%s' must be a pointer at %L",
2387                        f->sym->name, &a->expr->where);
2388           return 0;
2389         }
2390
2391       if (a->expr->expr_type != EXPR_NULL
2392           && (gfc_option.allow_std & GFC_STD_F2008) == 0
2393           && compare_pointer (f->sym, a->expr) == 2)
2394         {
2395           if (where)
2396             gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2397                        "pointer dummy '%s'", &a->expr->where,f->sym->name);
2398           return 0;
2399         }
2400
2401
2402       /* Fortran 2008, C1242.  */
2403       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2404         {
2405           if (where)
2406             gfc_error ("Coindexed actual argument at %L to pointer "
2407                        "dummy '%s'",
2408                        &a->expr->where, f->sym->name);
2409           return 0;
2410         }
2411
2412       /* Fortran 2008, 12.5.2.5 (no constraint).  */
2413       if (a->expr->expr_type == EXPR_VARIABLE
2414           && f->sym->attr.intent != INTENT_IN
2415           && f->sym->attr.allocatable
2416           && gfc_is_coindexed (a->expr))
2417         {
2418           if (where)
2419             gfc_error ("Coindexed actual argument at %L to allocatable "
2420                        "dummy '%s' requires INTENT(IN)",
2421                        &a->expr->where, f->sym->name);
2422           return 0;
2423         }
2424
2425       /* Fortran 2008, C1237.  */
2426       if (a->expr->expr_type == EXPR_VARIABLE
2427           && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2428           && gfc_is_coindexed (a->expr)
2429           && (a->expr->symtree->n.sym->attr.volatile_
2430               || a->expr->symtree->n.sym->attr.asynchronous))
2431         {
2432           if (where)
2433             gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2434                        "%L requires that dummy '%s' has neither "
2435                        "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2436                        f->sym->name);
2437           return 0;
2438         }
2439
2440       /* Fortran 2008, 12.5.2.4 (no constraint).  */
2441       if (a->expr->expr_type == EXPR_VARIABLE
2442           && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2443           && gfc_is_coindexed (a->expr)
2444           && gfc_has_ultimate_allocatable (a->expr))
2445         {
2446           if (where)
2447             gfc_error ("Coindexed actual argument at %L with allocatable "
2448                        "ultimate component to dummy '%s' requires either VALUE "
2449                        "or INTENT(IN)", &a->expr->where, f->sym->name);
2450           return 0;
2451         }
2452
2453      if (f->sym->ts.type == BT_CLASS
2454            && CLASS_DATA (f->sym)->attr.allocatable
2455            && gfc_is_class_array_ref (a->expr, &full_array)
2456            && !full_array)
2457         {
2458           if (where)
2459             gfc_error ("Actual CLASS array argument for '%s' must be a full "
2460                        "array at %L", f->sym->name, &a->expr->where);
2461           return 0;
2462         }
2463
2464
2465       if (a->expr->expr_type != EXPR_NULL
2466           && compare_allocatable (f->sym, a->expr) == 0)
2467         {
2468           if (where)
2469             gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2470                        f->sym->name, &a->expr->where);
2471           return 0;
2472         }
2473
2474       /* Check intent = OUT/INOUT for definable actual argument.  */
2475       if ((f->sym->attr.intent == INTENT_OUT
2476           || f->sym->attr.intent == INTENT_INOUT))
2477         {
2478           const char* context = (where
2479                                  ? _("actual argument to INTENT = OUT/INOUT")
2480                                  : NULL);
2481
2482           if (f->sym->attr.pointer
2483               && gfc_check_vardef_context (a->expr, true, false, context)
2484                    == FAILURE)
2485             return 0;
2486           if (gfc_check_vardef_context (a->expr, false, false, context)
2487                 == FAILURE)
2488             return 0;
2489         }
2490
2491       if ((f->sym->attr.intent == INTENT_OUT
2492            || f->sym->attr.intent == INTENT_INOUT
2493            || f->sym->attr.volatile_
2494            || f->sym->attr.asynchronous)
2495           && gfc_has_vector_subscript (a->expr))
2496         {
2497           if (where)
2498             gfc_error ("Array-section actual argument with vector "
2499                        "subscripts at %L is incompatible with INTENT(OUT), "
2500                        "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2501                        "of the dummy argument '%s'",
2502                        &a->expr->where, f->sym->name);
2503           return 0;
2504         }
2505
2506       /* C1232 (R1221) For an actual argument which is an array section or
2507          an assumed-shape array, the dummy argument shall be an assumed-
2508          shape array, if the dummy argument has the VOLATILE attribute.  */
2509
2510       if (f->sym->attr.volatile_
2511           && a->expr->symtree->n.sym->as
2512           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2513           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2514         {
2515           if (where)
2516             gfc_error ("Assumed-shape actual argument at %L is "
2517                        "incompatible with the non-assumed-shape "
2518                        "dummy argument '%s' due to VOLATILE attribute",
2519                        &a->expr->where,f->sym->name);
2520           return 0;
2521         }
2522
2523       if (f->sym->attr.volatile_
2524           && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2525           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2526         {
2527           if (where)
2528             gfc_error ("Array-section actual argument at %L is "
2529                        "incompatible with the non-assumed-shape "
2530                        "dummy argument '%s' due to VOLATILE attribute",
2531                        &a->expr->where,f->sym->name);
2532           return 0;
2533         }
2534
2535       /* C1233 (R1221) For an actual argument which is a pointer array, the
2536          dummy argument shall be an assumed-shape or pointer array, if the
2537          dummy argument has the VOLATILE attribute.  */
2538
2539       if (f->sym->attr.volatile_
2540           && a->expr->symtree->n.sym->attr.pointer
2541           && a->expr->symtree->n.sym->as
2542           && !(f->sym->as
2543                && (f->sym->as->type == AS_ASSUMED_SHAPE
2544                    || f->sym->attr.pointer)))
2545         {
2546           if (where)
2547             gfc_error ("Pointer-array actual argument at %L requires "
2548                        "an assumed-shape or pointer-array dummy "
2549                        "argument '%s' due to VOLATILE attribute",
2550                        &a->expr->where,f->sym->name);
2551           return 0;
2552         }
2553
2554     match:
2555       if (a == actual)
2556         na = i;
2557
2558       new_arg[i++] = a;
2559     }
2560
2561   /* Make sure missing actual arguments are optional.  */
2562   i = 0;
2563   for (f = formal; f; f = f->next, i++)
2564     {
2565       if (new_arg[i] != NULL)
2566         continue;
2567       if (f->sym == NULL)
2568         {
2569           if (where)
2570             gfc_error ("Missing alternate return spec in subroutine call "
2571                        "at %L", where);
2572           return 0;
2573         }
2574       if (!f->sym->attr.optional)
2575         {
2576           if (where)
2577             gfc_error ("Missing actual argument for argument '%s' at %L",
2578                        f->sym->name, where);
2579           return 0;
2580         }
2581     }
2582
2583   /* The argument lists are compatible.  We now relink a new actual
2584      argument list with null arguments in the right places.  The head
2585      of the list remains the head.  */
2586   for (i = 0; i < n; i++)
2587     if (new_arg[i] == NULL)
2588       new_arg[i] = gfc_get_actual_arglist ();
2589
2590   if (na != 0)
2591     {
2592       temp = *new_arg[0];
2593       *new_arg[0] = *actual;
2594       *actual = temp;
2595
2596       a = new_arg[0];
2597       new_arg[0] = new_arg[na];
2598       new_arg[na] = a;
2599     }
2600
2601   for (i = 0; i < n - 1; i++)
2602     new_arg[i]->next = new_arg[i + 1];
2603
2604   new_arg[i]->next = NULL;
2605
2606   if (*ap == NULL && n > 0)
2607     *ap = new_arg[0];
2608
2609   /* Note the types of omitted optional arguments.  */
2610   for (a = *ap, f = formal; a; a = a->next, f = f->next)
2611     if (a->expr == NULL && a->label == NULL)
2612       a->missing_arg_type = f->sym->ts.type;
2613
2614   return 1;
2615 }
2616
2617
2618 typedef struct
2619 {
2620   gfc_formal_arglist *f;
2621   gfc_actual_arglist *a;
2622 }
2623 argpair;
2624
2625 /* qsort comparison function for argument pairs, with the following
2626    order:
2627     - p->a->expr == NULL
2628     - p->a->expr->expr_type != EXPR_VARIABLE
2629     - growing p->a->expr->symbol.  */
2630
2631 static int
2632 pair_cmp (const void *p1, const void *p2)
2633 {
2634   const gfc_actual_arglist *a1, *a2;
2635
2636   /* *p1 and *p2 are elements of the to-be-sorted array.  */
2637   a1 = ((const argpair *) p1)->a;
2638   a2 = ((const argpair *) p2)->a;
2639   if (!a1->expr)
2640     {
2641       if (!a2->expr)
2642         return 0;
2643       return -1;
2644     }
2645   if (!a2->expr)
2646     return 1;
2647   if (a1->expr->expr_type != EXPR_VARIABLE)
2648     {
2649       if (a2->expr->expr_type != EXPR_VARIABLE)
2650         return 0;
2651       return -1;
2652     }
2653   if (a2->expr->expr_type != EXPR_VARIABLE)
2654     return 1;
2655   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2656 }
2657
2658
2659 /* Given two expressions from some actual arguments, test whether they
2660    refer to the same expression. The analysis is conservative.
2661    Returning FAILURE will produce no warning.  */
2662
2663 static gfc_try
2664 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2665 {
2666   const gfc_ref *r1, *r2;
2667
2668   if (!e1 || !e2
2669       || e1->expr_type != EXPR_VARIABLE
2670       || e2->expr_type != EXPR_VARIABLE
2671       || e1->symtree->n.sym != e2->symtree->n.sym)
2672     return FAILURE;
2673
2674   /* TODO: improve comparison, see expr.c:show_ref().  */
2675   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2676     {
2677       if (r1->type != r2->type)
2678         return FAILURE;
2679       switch (r1->type)
2680         {
2681         case REF_ARRAY:
2682           if (r1->u.ar.type != r2->u.ar.type)
2683             return FAILURE;
2684           /* TODO: At the moment, consider only full arrays;
2685              we could do better.  */
2686           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2687             return FAILURE;
2688           break;
2689
2690         case REF_COMPONENT:
2691           if (r1->u.c.component != r2->u.c.component)
2692             return FAILURE;
2693           break;
2694
2695         case REF_SUBSTRING:
2696           return FAILURE;
2697
2698         default:
2699           gfc_internal_error ("compare_actual_expr(): Bad component code");
2700         }
2701     }
2702   if (!r1 && !r2)
2703     return SUCCESS;
2704   return FAILURE;
2705 }
2706
2707
2708 /* Given formal and actual argument lists that correspond to one
2709    another, check that identical actual arguments aren't not
2710    associated with some incompatible INTENTs.  */
2711
2712 static gfc_try
2713 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2714 {
2715   sym_intent f1_intent, f2_intent;
2716   gfc_formal_arglist *f1;
2717   gfc_actual_arglist *a1;
2718   size_t n, i, j;
2719   argpair *p;
2720   gfc_try t = SUCCESS;
2721
2722   n = 0;
2723   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2724     {
2725       if (f1 == NULL && a1 == NULL)
2726         break;
2727       if (f1 == NULL || a1 == NULL)
2728         gfc_internal_error ("check_some_aliasing(): List mismatch");
2729       n++;
2730     }
2731   if (n == 0)
2732     return t;
2733   p = XALLOCAVEC (argpair, n);
2734
2735   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2736     {
2737       p[i].f = f1;
2738       p[i].a = a1;
2739     }
2740
2741   qsort (p, n, sizeof (argpair), pair_cmp);
2742
2743   for (i = 0; i < n; i++)
2744     {
2745       if (!p[i].a->expr
2746           || p[i].a->expr->expr_type != EXPR_VARIABLE
2747           || p[i].a->expr->ts.type == BT_PROCEDURE)
2748         continue;
2749       f1_intent = p[i].f->sym->attr.intent;
2750       for (j = i + 1; j < n; j++)
2751         {
2752           /* Expected order after the sort.  */
2753           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2754             gfc_internal_error ("check_some_aliasing(): corrupted data");
2755
2756           /* Are the expression the same?  */
2757           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2758             break;
2759           f2_intent = p[j].f->sym->attr.intent;
2760           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2761               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2762             {
2763               gfc_warning ("Same actual argument associated with INTENT(%s) "
2764                            "argument '%s' and INTENT(%s) argument '%s' at %L",
2765                            gfc_intent_string (f1_intent), p[i].f->sym->name,
2766                            gfc_intent_string (f2_intent), p[j].f->sym->name,
2767                            &p[i].a->expr->where);
2768               t = FAILURE;
2769             }
2770         }
2771     }
2772
2773   return t;
2774 }
2775
2776
2777 /* Given a symbol of a formal argument list and an expression,
2778    return nonzero if their intents are compatible, zero otherwise.  */
2779
2780 static int
2781 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2782 {
2783   if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2784     return 1;
2785
2786   if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2787     return 1;
2788
2789   if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2790     return 0;
2791
2792   return 1;
2793 }
2794
2795
2796 /* Given formal and actual argument lists that correspond to one
2797    another, check that they are compatible in the sense that intents
2798    are not mismatched.  */
2799
2800 static gfc_try
2801 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2802 {
2803   sym_intent f_intent;
2804
2805   for (;; f = f->next, a = a->next)
2806     {
2807       if (f == NULL && a == NULL)
2808         break;
2809       if (f == NULL || a == NULL)
2810         gfc_internal_error ("check_intents(): List mismatch");
2811
2812       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2813         continue;
2814
2815       f_intent = f->sym->attr.intent;
2816
2817       if (!compare_parameter_intent(f->sym, a->expr))
2818         {
2819           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2820                      "specifies INTENT(%s)", &a->expr->where,
2821                      gfc_intent_string (f_intent));
2822           return FAILURE;
2823         }
2824
2825       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2826         {
2827           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2828             {
2829               gfc_error ("Procedure argument at %L is local to a PURE "
2830                          "procedure and is passed to an INTENT(%s) argument",
2831                          &a->expr->where, gfc_intent_string (f_intent));
2832               return FAILURE;
2833             }
2834
2835           if (f->sym->attr.pointer)
2836             {
2837               gfc_error ("Procedure argument at %L is local to a PURE "
2838                          "procedure and has the POINTER attribute",
2839                          &a->expr->where);
2840               return FAILURE;
2841             }
2842         }
2843
2844        /* Fortran 2008, C1283.  */
2845        if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2846         {
2847           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2848             {
2849               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2850                          "is passed to an INTENT(%s) argument",
2851                          &a->expr->where, gfc_intent_string (f_intent));
2852               return FAILURE;
2853             }
2854
2855           if (f->sym->attr.pointer)
2856             {
2857               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2858                          "is passed to a POINTER dummy argument",
2859                          &a->expr->where);
2860               return FAILURE;
2861             }
2862         }
2863
2864        /* F2008, Section 12.5.2.4.  */
2865        if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2866            && gfc_is_coindexed (a->expr))
2867          {
2868            gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2869                       "polymorphic dummy argument '%s'",
2870                          &a->expr->where, f->sym->name);
2871            return FAILURE;
2872          }
2873     }
2874
2875   return SUCCESS;
2876 }
2877
2878
2879 /* Check how a procedure is used against its interface.  If all goes
2880    well, the actual argument list will also end up being properly
2881    sorted.  */
2882
2883 void
2884 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2885 {
2886
2887   /* Warn about calls with an implicit interface.  Special case
2888      for calling a ISO_C_BINDING becase c_loc and c_funloc
2889      are pseudo-unknown.  Additionally, warn about procedures not
2890      explicitly declared at all if requested.  */
2891   if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2892     {
2893       if (gfc_option.warn_implicit_interface)
2894         gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2895                      sym->name, where);
2896       else if (gfc_option.warn_implicit_procedure
2897                && sym->attr.proc == PROC_UNKNOWN)
2898         gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2899                      sym->name, where);
2900     }
2901
2902   if (sym->attr.if_source == IFSRC_UNKNOWN)
2903     {
2904       gfc_actual_arglist *a;
2905
2906       if (sym->attr.pointer)
2907         {
2908           gfc_error("The pointer object '%s' at %L must have an explicit "
2909                     "function interface or be declared as array",
2910                     sym->name, where);
2911           return;
2912         }
2913
2914       if (sym->attr.allocatable && !sym->attr.external)
2915         {
2916           gfc_error("The allocatable object '%s' at %L must have an explicit "
2917                     "function interface or be declared as array",
2918                     sym->name, where);
2919           return;
2920         }
2921
2922       if (sym->attr.allocatable)
2923         {
2924           gfc_error("Allocatable function '%s' at %L must have an explicit "
2925                     "function interface", sym->name, where);
2926           return;
2927         }
2928
2929       for (a = *ap; a; a = a->next)
2930         {
2931           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2932           if (a->name != NULL && a->name[0] != '%')
2933             {
2934               gfc_error("Keyword argument requires explicit interface "
2935                         "for procedure '%s' at %L", sym->name, &a->expr->where);
2936               break;
2937             }
2938
2939           /* F2008, C1303 and C1304.  */
2940           if (a->expr
2941               && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
2942               && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2943                    && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2944                   || gfc_expr_attr (a->expr).lock_comp))
2945             {
2946               gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
2947                         "component at %L requires an explicit interface for "
2948                         "procedure '%s'", &a->expr->where, sym->name);
2949               break;
2950             }
2951
2952           if (a->expr && a->expr->expr_type == EXPR_NULL
2953               && a->expr->ts.type == BT_UNKNOWN)
2954             {
2955               gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
2956               return;
2957             }
2958         }
2959
2960       return;
2961     }
2962
2963   if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2964     return;
2965
2966   check_intents (sym->formal, *ap);
2967   if (gfc_option.warn_aliasing)
2968     check_some_aliasing (sym->formal, *ap);
2969 }
2970
2971
2972 /* Check how a procedure pointer component is used against its interface.
2973    If all goes well, the actual argument list will also end up being properly
2974    sorted. Completely analogous to gfc_procedure_use.  */
2975
2976 void
2977 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2978 {
2979
2980   /* Warn about calls with an implicit interface.  Special case
2981      for calling a ISO_C_BINDING becase c_loc and c_funloc
2982      are pseudo-unknown.  */
2983   if (gfc_option.warn_implicit_interface
2984       && comp->attr.if_source == IFSRC_UNKNOWN
2985       && !comp->attr.is_iso_c)
2986     gfc_warning ("Procedure pointer component '%s' called with an implicit "
2987                  "interface at %L", comp->name, where);
2988
2989   if (comp->attr.if_source == IFSRC_UNKNOWN)
2990     {
2991       gfc_actual_arglist *a;
2992       for (a = *ap; a; a = a->next)
2993         {
2994           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2995           if (a->name != NULL && a->name[0] != '%')
2996             {
2997               gfc_error("Keyword argument requires explicit interface "
2998                         "for procedure pointer component '%s' at %L",
2999                         comp->name, &a->expr->where);
3000               break;
3001             }
3002         }
3003
3004       return;
3005     }
3006
3007   if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
3008     return;
3009
3010   check_intents (comp->formal, *ap);
3011   if (gfc_option.warn_aliasing)
3012     check_some_aliasing (comp->formal, *ap);
3013 }
3014
3015
3016 /* Try if an actual argument list matches the formal list of a symbol,
3017    respecting the symbol's attributes like ELEMENTAL.  This is used for
3018    GENERIC resolution.  */
3019
3020 bool
3021 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3022 {
3023   bool r;
3024
3025   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
3026
3027   r = !sym->attr.elemental;
3028   if (compare_actual_formal (args, sym->formal, r, !r, NULL))
3029     {
3030       check_intents (sym->formal, *args);
3031       if (gfc_option.warn_aliasing)
3032         check_some_aliasing (sym->formal, *args);
3033       return true;
3034     }
3035
3036   return false;
3037 }
3038
3039
3040 /* Given an interface pointer and an actual argument list, search for
3041    a formal argument list that matches the actual.  If found, returns
3042    a pointer to the symbol of the correct interface.  Returns NULL if
3043    not found.  */
3044
3045 gfc_symbol *
3046 gfc_search_interface (gfc_interface *intr, int sub_flag,
3047                       gfc_actual_arglist **ap)
3048 {
3049   gfc_symbol *elem_sym = NULL;
3050   gfc_symbol *null_sym = NULL;
3051   locus null_expr_loc;
3052   gfc_actual_arglist *a;
3053   bool has_null_arg = false;
3054
3055   for (a = *ap; a; a = a->next)
3056     if (a->expr && a->expr->expr_type == EXPR_NULL
3057         && a->expr->ts.type == BT_UNKNOWN)
3058       {
3059         has_null_arg = true;
3060         null_expr_loc = a->expr->where;
3061         break;
3062       }
3063
3064   for (; intr; intr = intr->next)
3065     {
3066       if (intr->sym->attr.flavor == FL_DERIVED)
3067         continue;
3068       if (sub_flag && intr->sym->attr.function)
3069         continue;
3070       if (!sub_flag && intr->sym->attr.subroutine)
3071         continue;
3072
3073       if (gfc_arglist_matches_symbol (ap, intr->sym))
3074         {
3075           if (has_null_arg && null_sym)
3076             {
3077               gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3078                          "between specific functions %s and %s",
3079                          &null_expr_loc, null_sym->name, intr->sym->name);
3080               return NULL;
3081             }
3082           else if (has_null_arg)
3083             {
3084               null_sym = intr->sym;
3085               continue;
3086             }
3087
3088           /* Satisfy 12.4.4.1 such that an elemental match has lower
3089              weight than a non-elemental match.  */
3090           if (intr->sym->attr.elemental)
3091             {
3092               elem_sym = intr->sym;
3093               continue;
3094             }
3095           return intr->sym;
3096         }
3097     }
3098
3099   if (null_sym)
3100     return null_sym;
3101
3102   return elem_sym ? elem_sym : NULL;
3103 }
3104
3105
3106 /* Do a brute force recursive search for a symbol.  */
3107
3108 static gfc_symtree *
3109 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3110 {
3111   gfc_symtree * st;
3112
3113   if (root->n.sym == sym)
3114     return root;
3115
3116   st = NULL;
3117   if (root->left)
3118     st = find_symtree0 (root->left, sym);
3119   if (root->right && ! st)
3120     st = find_symtree0 (root->right, sym);
3121   return st;
3122 }
3123
3124
3125 /* Find a symtree for a symbol.  */
3126
3127 gfc_symtree *
3128 gfc_find_sym_in_symtree (gfc_symbol *sym)
3129 {
3130   gfc_symtree *st;
3131   gfc_namespace *ns;
3132
3133   /* First try to find it by name.  */
3134   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3135   if (st && st->n.sym == sym)
3136     return st;
3137
3138   /* If it's been renamed, resort to a brute-force search.  */
3139   /* TODO: avoid having to do this search.  If the symbol doesn't exist
3140      in the symtree for the current namespace, it should probably be added.  */
3141   for (ns = gfc_current_ns; ns; ns = ns->parent)
3142     {
3143       st = find_symtree0 (ns->sym_root, sym);
3144       if (st)
3145         return st;
3146     }
3147   gfc_internal_error ("Unable to find symbol %s", sym->name);
3148   /* Not reached.  */
3149 }
3150
3151
3152 /* See if the arglist to an operator-call contains a derived-type argument
3153    with a matching type-bound operator.  If so, return the matching specific
3154    procedure defined as operator-target as well as the base-object to use
3155    (which is the found derived-type argument with operator).  The generic
3156    name, if any, is transmitted to the final expression via 'gname'.  */
3157
3158 static gfc_typebound_proc*
3159 matching_typebound_op (gfc_expr** tb_base,
3160                        gfc_actual_arglist* args,
3161                        gfc_intrinsic_op op, const char* uop,
3162                        const char ** gname)
3163 {
3164   gfc_actual_arglist* base;
3165
3166   for (base = args; base; base = base->next)
3167     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3168       {
3169         gfc_typebound_proc* tb;
3170         gfc_symbol* derived;
3171         gfc_try result;
3172
3173         while (base->expr->expr_type == EXPR_OP
3174                && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3175           base->expr = base->expr->value.op.op1;
3176
3177         if (base->expr->ts.type == BT_CLASS)
3178           {
3179             if (CLASS_DATA (base->expr) == NULL)
3180               continue;
3181             derived = CLASS_DATA (base->expr)->ts.u.derived;
3182           }
3183         else
3184           derived = base->expr->ts.u.derived;
3185
3186         if (op == INTRINSIC_USER)
3187           {
3188             gfc_symtree* tb_uop;
3189
3190             gcc_assert (uop);
3191             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3192                                                  false, NULL);
3193
3194             if (tb_uop)
3195               tb = tb_uop->n.tb;
3196             else
3197               tb = NULL;
3198           }
3199         else
3200           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3201                                                 false, NULL);
3202
3203         /* This means we hit a PRIVATE operator which is use-associated and
3204            should thus not be seen.  */
3205         if (result == FAILURE)
3206           tb = NULL;
3207
3208         /* Look through the super-type hierarchy for a matching specific
3209            binding.  */
3210         for (; tb; tb = tb->overridden)
3211           {
3212             gfc_tbp_generic* g;
3213
3214             gcc_assert (tb->is_generic);
3215             for (g = tb->u.generic; g; g = g->next)
3216               {
3217                 gfc_symbol* target;
3218                 gfc_actual_arglist* argcopy;
3219                 bool matches;
3220
3221                 gcc_assert (g->specific);
3222                 if (g->specific->error)
3223                   continue;
3224
3225                 target = g->specific->u.specific->n.sym;
3226
3227                 /* Check if this arglist matches the formal.  */
3228                 argcopy = gfc_copy_actual_arglist (args);
3229                 matches = gfc_arglist_matches_symbol (&argcopy, target);
3230                 gfc_free_actual_arglist (argcopy);
3231
3232                 /* Return if we found a match.  */
3233                 if (matches)
3234                   {
3235                     *tb_base = base->expr;
3236                     *gname = g->specific_st->name;
3237                     return g->specific;
3238                   }
3239               }
3240           }
3241       }
3242
3243   return NULL;
3244 }
3245
3246
3247 /* For the 'actual arglist' of an operator call and a specific typebound
3248    procedure that has been found the target of a type-bound operator, build the
3249    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
3250    type-bound procedures rather than resolving type-bound operators 'directly'
3251    so that we can reuse the existing logic.  */
3252
3253 static void
3254 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3255                              gfc_expr* base, gfc_typebound_proc* target,
3256                              const char *gname)
3257 {
3258   e->expr_type = EXPR_COMPCALL;
3259   e->value.compcall.tbp = target;
3260   e->value.compcall.name = gname ? gname : "$op";
3261   e->value.compcall.actual = actual;
3262   e->value.compcall.base_object = base;
3263   e->value.compcall.ignore_pass = 1;
3264   e->value.compcall.assign = 0;
3265   if (e->ts.type == BT_UNKNOWN
3266         && target->function)
3267     {
3268       if (target->is_generic)
3269         e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3270       else
3271         e->ts = target->u.specific->n.sym->ts;
3272     }
3273 }
3274
3275
3276 /* This subroutine is called when an expression is being resolved.
3277    The expression node in question is either a user defined operator
3278    or an intrinsic operator with arguments that aren't compatible
3279    with the operator.  This subroutine builds an actual argument list
3280    corresponding to the operands, then searches for a compatible
3281    interface.  If one is found, the expression node is replaced with
3282    the appropriate function call. We use the 'match' enum to specify
3283    whether a replacement has been made or not, or if an error occurred.  */
3284
3285 match
3286 gfc_extend_expr (gfc_expr *e)
3287 {
3288   gfc_actual_arglist *actual;
3289   gfc_symbol *sym;
3290   gfc_namespace *ns;
3291   gfc_user_op *uop;
3292   gfc_intrinsic_op i;
3293   const char *gname;
3294
3295   sym = NULL;
3296
3297   actual = gfc_get_actual_arglist ();
3298   actual->expr = e->value.op.op1;
3299
3300   gname = NULL;
3301
3302   if (e->value.op.op2 != NULL)
3303     {
3304       actual->next = gfc_get_actual_arglist ();
3305       actual->next->expr = e->value.op.op2;
3306     }
3307
3308   i = fold_unary_intrinsic (e->value.op.op);
3309
3310   if (i == INTRINSIC_USER)
3311     {
3312       for (ns = gfc_current_ns; ns; ns = ns->parent)
3313         {
3314           uop = gfc_find_uop (e->value.op.uop->name, ns);
3315           if (uop == NULL)
3316             continue;
3317
3318           sym = gfc_search_interface (uop->op, 0, &actual);
3319           if (sym != NULL)
3320             break;
3321         }
3322     }
3323   else
3324     {
3325       for (ns = gfc_current_ns; ns; ns = ns->parent)
3326         {
3327           /* Due to the distinction between '==' and '.eq.' and friends, one has
3328              to check if either is defined.  */
3329           switch (i)
3330             {
3331 #define CHECK_OS_COMPARISON(comp) \
3332   case INTRINSIC_##comp: \
3333   case INTRINSIC_##comp##_OS: \
3334     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3335     if (!sym) \
3336       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3337     break;
3338               CHECK_OS_COMPARISON(EQ)
3339               CHECK_OS_COMPARISON(NE)
3340               CHECK_OS_COMPARISON(GT)
3341               CHECK_OS_COMPARISON(GE)
3342               CHECK_OS_COMPARISON(LT)
3343               CHECK_OS_COMPARISON(LE)
3344 #undef CHECK_OS_COMPARISON
3345
3346               default:
3347                 sym = gfc_search_interface (ns->op[i], 0, &actual);
3348             }
3349
3350           if (sym != NULL)
3351             break;
3352         }
3353     }
3354
3355   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3356      found rather than just taking the first one and not checking further.  */
3357
3358   if (sym == NULL)
3359     {
3360       gfc_typebound_proc* tbo;
3361       gfc_expr* tb_base;
3362
3363       /* See if we find a matching type-bound operator.  */
3364       if (i == INTRINSIC_USER)
3365         tbo = matching_typebound_op (&tb_base, actual,
3366                                      i, e->value.op.uop->name, &gname);
3367       else
3368         switch (i)
3369           {
3370 #define CHECK_OS_COMPARISON(comp) \
3371   case INTRINSIC_##comp: \
3372   case INTRINSIC_##comp##_OS: \
3373     tbo = matching_typebound_op (&tb_base, actual, \
3374                                  INTRINSIC_##comp, NULL, &gname); \
3375     if (!tbo) \
3376       tbo = matching_typebound_op (&tb_base, actual, \
3377                                    INTRINSIC_##comp##_OS, NULL, &gname); \
3378     break;
3379             CHECK_OS_COMPARISON(EQ)
3380             CHECK_OS_COMPARISON(NE)
3381             CHECK_OS_COMPARISON(GT)
3382             CHECK_OS_COMPARISON(GE)
3383             CHECK_OS_COMPARISON(LT)
3384             CHECK_OS_COMPARISON(LE)
3385 #undef CHECK_OS_COMPARISON
3386
3387             default:
3388               tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3389               break;
3390           }
3391
3392       /* If there is a matching typebound-operator, replace the expression with
3393          a call to it and succeed.  */
3394       if (tbo)
3395         {
3396           gfc_try result;
3397
3398           gcc_assert (tb_base);
3399           build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3400
3401           result = gfc_resolve_expr (e);
3402           if (result == FAILURE)
3403             return MATCH_ERROR;
3404
3405           return MATCH_YES;
3406         }
3407
3408       /* Don't use gfc_free_actual_arglist().  */
3409       free (actual->next);
3410       free (actual);
3411
3412       return MATCH_NO;
3413     }
3414
3415   /* Change the expression node to a function call.  */
3416   e->expr_type = EXPR_FUNCTION;
3417   e->symtree = gfc_find_sym_in_symtree (sym);
3418   e->value.function.actual = actual;
3419   e->value.function.esym = NULL;
3420   e->value.function.isym = NULL;
3421   e->value.function.name = NULL;
3422   e->user_operator = 1;
3423
3424   if (gfc_resolve_expr (e) == FAILURE)
3425     return MATCH_ERROR;
3426
3427   return MATCH_YES;
3428 }
3429
3430
3431 /* Tries to replace an assignment code node with a subroutine call to
3432    the subroutine associated with the assignment operator.  Return
3433    SUCCESS if the node was replaced.  On FAILURE, no error is
3434    generated.  */
3435
3436 gfc_try
3437 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3438 {
3439   gfc_actual_arglist *actual;
3440   gfc_expr *lhs, *rhs;
3441   gfc_symbol *sym;
3442   const char *gname;
3443
3444   gname = NULL;
3445
3446   lhs = c->expr1;
3447   rhs = c->expr2;
3448
3449   /* Don't allow an intrinsic assignment to be replaced.  */
3450   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3451       && (rhs->rank == 0 || rhs->rank == lhs->rank)
3452       && (lhs->ts.type == rhs->ts.type
3453           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3454     return FAILURE;
3455
3456   actual = gfc_get_actual_arglist ();
3457   actual->expr = lhs;
3458
3459   actual->next = gfc_get_actual_arglist ();
3460   actual->next->expr = rhs;
3461
3462   sym = NULL;
3463
3464   for (; ns; ns = ns->parent)
3465     {
3466       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3467       if (sym != NULL)
3468         break;
3469     }
3470
3471   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
3472
3473   if (sym == NULL)
3474     {
3475       gfc_typebound_proc* tbo;
3476       gfc_expr* tb_base;
3477
3478       /* See if we find a matching type-bound assignment.  */
3479       tbo = matching_typebound_op (&tb_base, actual,
3480                                    INTRINSIC_ASSIGN, NULL, &gname);
3481
3482       /* If there is one, replace the expression with a call to it and
3483          succeed.  */
3484       if (tbo)
3485         {
3486           gcc_assert (tb_base);
3487           c->expr1 = gfc_get_expr ();
3488           build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3489           c->expr1->value.compcall.assign = 1;
3490           c->expr1->where = c->loc;
3491           c->expr2 = NULL;
3492           c->op = EXEC_COMPCALL;
3493
3494           /* c is resolved from the caller, so no need to do it here.  */
3495
3496           return SUCCESS;
3497         }
3498
3499       free (actual->next);
3500       free (actual);
3501       return FAILURE;
3502     }
3503
3504   /* Replace the assignment with the call.  */
3505   c->op = EXEC_ASSIGN_CALL;
3506   c->symtree = gfc_find_sym_in_symtree (sym);
3507   c->expr1 = NULL;
3508   c->expr2 = NULL;
3509   c->ext.actual = actual;
3510
3511   return SUCCESS;
3512 }
3513
3514
3515 /* Make sure that the interface just parsed is not already present in
3516    the given interface list.  Ambiguity isn't checked yet since module
3517    procedures can be present without interfaces.  */
3518
3519 static gfc_try
3520 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
3521 {
3522   gfc_interface *ip;
3523
3524   for (ip = base; ip; ip = ip->next)
3525     {
3526       if (ip->sym == new_sym)
3527         {
3528           gfc_error ("Entity '%s' at %C is already present in the interface",
3529                      new_sym->name);
3530           return FAILURE;
3531         }
3532     }
3533
3534   return SUCCESS;
3535 }
3536
3537
3538 /* Add a symbol to the current interface.  */
3539
3540 gfc_try
3541 gfc_add_interface (gfc_symbol *new_sym)
3542 {
3543   gfc_interface **head, *intr;
3544   gfc_namespace *ns;
3545   gfc_symbol *sym;
3546
3547   switch (current_interface.type)
3548     {
3549     case INTERFACE_NAMELESS:
3550     case INTERFACE_ABSTRACT:
3551       return SUCCESS;
3552
3553     case INTERFACE_INTRINSIC_OP:
3554       for (ns = current_interface.ns; ns; ns = ns->parent)
3555         switch (current_interface.op)
3556           {
3557             case INTRINSIC_EQ:
3558             case INTRINSIC_EQ_OS:
3559               if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
3560                   check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
3561                 return FAILURE;
3562               break;
3563
3564             case INTRINSIC_NE:
3565             case INTRINSIC_NE_OS:
3566               if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
3567                   check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
3568                 return FAILURE;
3569               break;
3570
3571             case INTRINSIC_GT:
3572             case INTRINSIC_GT_OS:
3573               if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
3574                   check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
3575                 return FAILURE;
3576               break;
3577
3578             case INTRINSIC_GE:
3579             case INTRINSIC_GE_OS:
3580               if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
3581                   check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
3582                 return FAILURE;
3583               break;
3584
3585             case INTRINSIC_LT:
3586             case INTRINSIC_LT_OS:
3587               if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
3588                   check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
3589                 return FAILURE;
3590               break;
3591
3592             case INTRINSIC_LE:
3593             case INTRINSIC_LE_OS:
3594               if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
3595                   check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3596                 return FAILURE;
3597               break;
3598
3599             default:
3600               if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3601                 return FAILURE;
3602           }
3603
3604       head = &current_interface.ns->op[current_interface.op];
3605       break;
3606
3607     case INTERFACE_GENERIC:
3608       for (ns = current_interface.ns; ns; ns = ns->parent)
3609         {
3610           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3611           if (sym == NULL)
3612             continue;
3613
3614           if (check_new_interface (sym->generic, new_sym) == FAILURE)
3615             return FAILURE;
3616         }
3617
3618       head = &current_interface.sym->generic;
3619       break;
3620
3621     case INTERFACE_USER_OP:
3622       if (check_new_interface (current_interface.uop->op, new_sym)
3623           == FAILURE)
3624         return FAILURE;
3625
3626       head = &current_interface.uop->op;
3627       break;
3628
3629     default:
3630       gfc_internal_error ("gfc_add_interface(): Bad interface type");
3631     }
3632
3633   intr = gfc_get_interface ();
3634   intr->sym = new_sym;
3635   intr->where = gfc_current_locus;
3636
3637   intr->next = *head;
3638   *head = intr;
3639
3640   return SUCCESS;
3641 }
3642
3643
3644 gfc_interface *
3645 gfc_current_interface_head (void)
3646 {
3647   switch (current_interface.type)
3648     {
3649       case INTERFACE_INTRINSIC_OP:
3650         return current_interface.ns->op[current_interface.op];
3651         break;
3652
3653       case INTERFACE_GENERIC:
3654         return current_interface.sym->generic;
3655         break;
3656
3657       case INTERFACE_USER_OP:
3658         return current_interface.uop->op;
3659         break;
3660
3661       default:
3662         gcc_unreachable ();
3663     }
3664 }
3665
3666
3667 void
3668 gfc_set_current_interface_head (gfc_interface *i)
3669 {
3670   switch (current_interface.type)
3671     {
3672       case INTERFACE_INTRINSIC_OP:
3673         current_interface.ns->op[current_interface.op] = i;
3674         break;
3675
3676       case INTERFACE_GENERIC:
3677         current_interface.sym->generic = i;
3678         break;
3679
3680       case INTERFACE_USER_OP:
3681         current_interface.uop->op = i;
3682         break;
3683
3684       default:
3685         gcc_unreachable ();
3686     }
3687 }
3688
3689
3690 /* Gets rid of a formal argument list.  We do not free symbols.
3691    Symbols are freed when a namespace is freed.  */
3692
3693 void
3694 gfc_free_formal_arglist (gfc_formal_arglist *p)
3695 {
3696   gfc_formal_arglist *q;
3697
3698   for (; p; p = q)
3699     {
3700       q = p->next;
3701       free (p);
3702     }
3703 }
3704
3705
3706 /* Check that it is ok for the type-bound procedure 'proc' to override the
3707    procedure 'old', cf. F08:4.5.7.3.  */
3708
3709 gfc_try
3710 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3711 {
3712   locus where;
3713   const gfc_symbol *proc_target, *old_target;
3714   unsigned proc_pass_arg, old_pass_arg, argpos;
3715   gfc_formal_arglist *proc_formal, *old_formal;
3716   bool check_type;
3717   char err[200];
3718
3719   /* This procedure should only be called for non-GENERIC proc.  */
3720   gcc_assert (!proc->n.tb->is_generic);
3721
3722   /* If the overwritten procedure is GENERIC, this is an error.  */
3723   if (old->n.tb->is_generic)
3724     {
3725       gfc_error ("Can't overwrite GENERIC '%s' at %L",
3726                  old->name, &proc->n.tb->where);
3727       return FAILURE;
3728     }
3729
3730   where = proc->n.tb->where;
3731   proc_target = proc->n.tb->u.specific->n.sym;
3732   old_target = old->n.tb->u.specific->n.sym;
3733
3734   /* Check that overridden binding is not NON_OVERRIDABLE.  */
3735   if (old->n.tb->non_overridable)
3736     {
3737       gfc_error ("'%s' at %L overrides a procedure binding declared"
3738                  " NON_OVERRIDABLE", proc->name, &where);
3739       return FAILURE;
3740     }
3741
3742   /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
3743   if (!old->n.tb->deferred && proc->n.tb->deferred)
3744     {
3745       gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3746                  " non-DEFERRED binding", proc->name, &where);
3747       return FAILURE;
3748     }
3749
3750   /* If the overridden binding is PURE, the overriding must be, too.  */
3751   if (old_target->attr.pure && !proc_target->attr.pure)
3752     {
3753       gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3754                  proc->name, &where);
3755       return FAILURE;
3756     }
3757
3758   /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
3759      is not, the overriding must not be either.  */
3760   if (old_target->attr.elemental && !proc_target->attr.elemental)
3761     {
3762       gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3763                  " ELEMENTAL", proc->name, &where);
3764       return FAILURE;
3765     }
3766   if (!old_target->attr.elemental && proc_target->attr.elemental)
3767     {
3768       gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3769                  " be ELEMENTAL, either", proc->name, &where);
3770       return FAILURE;
3771     }
3772
3773   /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3774      SUBROUTINE.  */
3775   if (old_target->attr.subroutine && !proc_target->attr.subroutine)
3776     {
3777       gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3778                  " SUBROUTINE", proc->name, &where);
3779       return FAILURE;
3780     }
3781
3782   /* If the overridden binding is a FUNCTION, the overriding must also be a
3783      FUNCTION and have the same characteristics.  */
3784   if (old_target->attr.function)
3785     {
3786       if (!proc_target->attr.function)
3787         {
3788           gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3789                      " FUNCTION", proc->name, &where);
3790           return FAILURE;
3791         }
3792
3793       /* FIXME:  Do more comprehensive checking (including, for instance, the
3794          array-shape).  */
3795       gcc_assert (proc_target->result && old_target->result);
3796       if (!compare_type_rank (proc_target->result, old_target->result))
3797         {
3798           gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3799                      " matching result types and ranks", proc->name, &where);
3800           return FAILURE;
3801         }
3802
3803       /* Check string length.  */
3804       if (proc_target->result->ts.type == BT_CHARACTER
3805           && proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
3806         {
3807           int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
3808                                               old_target->result->ts.u.cl->length);
3809           switch (compval)
3810           {
3811             case -1:
3812             case  1:
3813             case -3:
3814               gfc_error ("Character length mismatch between '%s' at '%L' and "
3815                          "overridden FUNCTION", proc->name, &where);
3816               return FAILURE;
3817
3818             case -2:
3819               gfc_warning ("Possible character length mismatch between '%s' at"
3820                            " '%L' and overridden FUNCTION", proc->name, &where);
3821               break;
3822
3823             case 0:
3824               break;
3825
3826             default:
3827               gfc_internal_error ("gfc_check_typebound_override: Unexpected "
3828                                   "result %i of gfc_dep_compare_expr", compval);
3829               break;
3830           }
3831         }
3832     }
3833
3834   /* If the overridden binding is PUBLIC, the overriding one must not be
3835      PRIVATE.  */
3836   if (old->n.tb->access == ACCESS_PUBLIC
3837       && proc->n.tb->access == ACCESS_PRIVATE)
3838     {
3839       gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3840                  " PRIVATE", proc->name, &where);
3841       return FAILURE;
3842     }
3843
3844   /* Compare the formal argument lists of both procedures.  This is also abused
3845      to find the position of the passed-object dummy arguments of both
3846      bindings as at least the overridden one might not yet be resolved and we
3847      need those positions in the check below.  */
3848   proc_pass_arg = old_pass_arg = 0;
3849   if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
3850     proc_pass_arg = 1;
3851   if (!old->n.tb->nopass && !old->n.tb->pass_arg)
3852     old_pass_arg = 1;
3853   argpos = 1;
3854   for (proc_formal = proc_target->formal, old_formal = old_target->formal;
3855        proc_formal && old_formal;
3856        proc_formal = proc_formal->next, old_formal = old_formal->next)
3857     {
3858       if (proc->n.tb->pass_arg
3859           && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
3860         proc_pass_arg = argpos;
3861       if (old->n.tb->pass_arg
3862           && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
3863         old_pass_arg = argpos;
3864
3865       /* Check that the names correspond.  */
3866       if (strcmp (proc_formal->sym->name, old_formal->sym->name))
3867         {
3868           gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3869                      " to match the corresponding argument of the overridden"
3870                      " procedure", proc_formal->sym->name, proc->name, &where,
3871                      old_formal->sym->name);
3872           return FAILURE;
3873         }
3874
3875       check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
3876       if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
3877                                        check_type, err, sizeof(err)) == FAILURE)
3878         {
3879           gfc_error ("Argument mismatch for the overriding procedure "
3880                      "'%s' at %L: %s", proc->name, &where, err);
3881           return FAILURE;
3882         }
3883
3884       ++argpos;
3885     }
3886   if (proc_formal || old_formal)
3887     {
3888       gfc_error ("'%s' at %L must have the same number of formal arguments as"
3889                  " the overridden procedure", proc->name, &where);
3890       return FAILURE;
3891     }
3892
3893   /* If the overridden binding is NOPASS, the overriding one must also be
3894      NOPASS.  */
3895   if (old->n.tb->nopass && !proc->n.tb->nopass)
3896     {
3897       gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3898                  " NOPASS", proc->name, &where);
3899       return FAILURE;
3900     }
3901
3902   /* If the overridden binding is PASS(x), the overriding one must also be
3903      PASS and the passed-object dummy arguments must correspond.  */
3904   if (!old->n.tb->nopass)
3905     {
3906       if (proc->n.tb->nopass)
3907         {
3908           gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3909                      " PASS", proc->name, &where);
3910           return FAILURE;
3911         }
3912
3913       if (proc_pass_arg != old_pass_arg)
3914         {
3915           gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3916                      " the same position as the passed-object dummy argument of"
3917                      " the overridden procedure", proc->name, &where);
3918           return FAILURE;
3919         }
3920     }
3921
3922   return SUCCESS;
3923 }