gcc/fortran/interface.c

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