old-autovect-branch/gcc/fortran/interface.c

   1 /* Deal with interfaces.
   2    Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  21
  22
  23 /* Deal with interfaces.  An explicit interface is represented as a
  24    singly linked list of formal argument structures attached to the
  25    relevant symbols.  For an implicit interface, the arguments don't
  26    point to symbols.  Explicit interfaces point to namespaces that
  27    contain the symbols within that interface.
  28
  29    Implicit interfaces are linked together in a singly linked list
  30    along the next_if member of symbol nodes.  Since a particular
  31    symbol can only have a single explicit interface, the symbol cannot
  32    be part of multiple lists and a single next-member suffices.
  33
  34    This is not the case for general classes, though.  An operator
  35    definition is independent of just about all other uses and has it's
  36    own head pointer.
  37
  38    Nameless interfaces:
  39      Nameless interfaces create symbols with explicit interfaces within
  40      the current namespace.  They are otherwise unlinked.
  41
  42    Generic interfaces:
  43      The generic name points to a linked list of symbols.  Each symbol
  44      has an explicit interface.  Each explicit interface has its own
  45      namespace containing the arguments.  Module procedures are symbols in
  46      which the interface is added later when the module procedure is parsed.
  47
  48    User operators:
  49      User-defined operators are stored in a their own set of symtrees
  50      separate from regular symbols.  The symtrees point to gfc_user_op
  51      structures which in turn head up a list of relevant interfaces.
  52
  53    Extended intrinsics and assignment:
  54      The head of these interface lists are stored in the containing namespace.
  55
  56    Implicit interfaces:
  57      An implicit interface is represented as a singly linked list of
  58      formal argument list structures that don't point to any symbol
  59      nodes -- they just contain types.
  60
  61
  62    When a subprogram is defined, the program unit's name points to an
  63    interface as usual, but the link to the namespace is NULL and the
  64    formal argument list points to symbols within the same namespace as
  65    the program unit name.  */
  66
  67 #include "config.h"
  68 #include "system.h"
  69 #include "gfortran.h"
  70 #include "match.h"
  71
  72
  73 /* The current_interface structure holds information about the
  74    interface currently being parsed.  This structure is saved and
  75    restored during recursive interfaces.  */
  76
  77 gfc_interface_info current_interface;
  78
  79
  80 /* Free a singly linked list of gfc_interface structures.  */
  81
  82 void
  83 gfc_free_interface (gfc_interface * intr)
  84 {
  85   gfc_interface *next;
  86
  87   for (; intr; intr = next)
  88     {
  89       next = intr->next;
  90       gfc_free (intr);
  91     }
  92 }
  93
  94
  95 /* Change the operators unary plus and minus into binary plus and
  96    minus respectively, leaving the rest unchanged.  */
  97
  98 static gfc_intrinsic_op
  99 fold_unary (gfc_intrinsic_op operator)
 100 {
 101
 102   switch (operator)
 103     {
 104     case INTRINSIC_UPLUS:
 105       operator = INTRINSIC_PLUS;
 106       break;
 107     case INTRINSIC_UMINUS:
 108       operator = INTRINSIC_MINUS;
 109       break;
 110     default:
 111       break;
 112     }
 113
 114   return operator;
 115 }
 116
 117
 118 /* Match a generic specification.  Depending on which type of
 119    interface is found, the 'name' or 'operator' 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 *operator)
 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       *operator = 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       *operator = fold_unary (i);
 142       return MATCH_YES;
 143     }
 144
 145   if (gfc_match (" operator ( ") == MATCH_YES)
 146     {
 147       m = gfc_match_defined_op_name (buffer, 1);
 148       if (m == MATCH_NO)
 149         goto syntax;
 150       if (m != MATCH_YES)
 151         return MATCH_ERROR;
 152
 153       m = gfc_match_char (')');
 154       if (m == MATCH_NO)
 155         goto syntax;
 156       if (m != MATCH_YES)
 157         return MATCH_ERROR;
 158
 159       strcpy (name, buffer);
 160       *type = INTERFACE_USER_OP;
 161       return MATCH_YES;
 162     }
 163
 164   if (gfc_match_name (buffer) == MATCH_YES)
 165     {
 166       strcpy (name, buffer);
 167       *type = INTERFACE_GENERIC;
 168       return MATCH_YES;
 169     }
 170
 171   *type = INTERFACE_NAMELESS;
 172   return MATCH_YES;
 173
 174 syntax:
 175   gfc_error ("Syntax error in generic specification at %C");
 176   return MATCH_ERROR;
 177 }
 178
 179
 180 /* Match one of the five forms of an interface statement.  */
 181
 182 match
 183 gfc_match_interface (void)
 184 {
 185   char name[GFC_MAX_SYMBOL_LEN + 1];
 186   interface_type type;
 187   gfc_symbol *sym;
 188   gfc_intrinsic_op operator;
 189   match m;
 190
 191   m = gfc_match_space ();
 192
 193   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
 194     return MATCH_ERROR;
 195
 196
 197   /* If we're not looking at the end of the statement now, or if this
 198      is not a nameless interface but we did not see a space, punt.  */
 199   if (gfc_match_eos () != MATCH_YES
 200       || (type != INTERFACE_NAMELESS
 201           && m != MATCH_YES))
 202     {
 203       gfc_error
 204         ("Syntax error: Trailing garbage in INTERFACE statement 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       current_interface.sym = gfc_new_block = sym;
 221       break;
 222
 223     case INTERFACE_USER_OP:
 224       current_interface.uop = gfc_get_uop (name);
 225       break;
 226
 227     case INTERFACE_INTRINSIC_OP:
 228       current_interface.op = operator;
 229       break;
 230
 231     case INTERFACE_NAMELESS:
 232       break;
 233     }
 234
 235   return MATCH_YES;
 236 }
 237
 238
 239 /* Match the different sort of generic-specs that can be present after
 240    the END INTERFACE itself.  */
 241
 242 match
 243 gfc_match_end_interface (void)
 244 {
 245   char name[GFC_MAX_SYMBOL_LEN + 1];
 246   interface_type type;
 247   gfc_intrinsic_op operator;
 248   match m;
 249
 250   m = gfc_match_space ();
 251
 252   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
 253     return MATCH_ERROR;
 254
 255   /* If we're not looking at the end of the statement now, or if this
 256      is not a nameless interface but we did not see a space, punt.  */
 257   if (gfc_match_eos () != MATCH_YES
 258       || (type != INTERFACE_NAMELESS
 259           && m != MATCH_YES))
 260     {
 261       gfc_error
 262         ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
 263       return MATCH_ERROR;
 264     }
 265
 266   m = MATCH_YES;
 267
 268   switch (current_interface.type)
 269     {
 270     case INTERFACE_NAMELESS:
 271       if (type != current_interface.type)
 272         {
 273           gfc_error ("Expected a nameless interface at %C");
 274           m = MATCH_ERROR;
 275         }
 276
 277       break;
 278
 279     case INTERFACE_INTRINSIC_OP:
 280       if (type != current_interface.type || operator != current_interface.op)
 281         {
 282
 283           if (current_interface.op == INTRINSIC_ASSIGN)
 284             gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
 285           else
 286             gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
 287                        gfc_op2string (current_interface.op));
 288
 289           m = MATCH_ERROR;
 290         }
 291
 292       break;
 293
 294     case INTERFACE_USER_OP:
 295       /* Comparing the symbol node names is OK because only use-associated
 296          symbols can be renamed.  */
 297       if (type != current_interface.type
 298           || strcmp (current_interface.uop->name, name) != 0)
 299         {
 300           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
 301                      current_interface.uop->name);
 302           m = MATCH_ERROR;
 303         }
 304
 305       break;
 306
 307     case INTERFACE_GENERIC:
 308       if (type != current_interface.type
 309           || strcmp (current_interface.sym->name, name) != 0)
 310         {
 311           gfc_error ("Expecting 'END INTERFACE %s' at %C",
 312                      current_interface.sym->name);
 313           m = MATCH_ERROR;
 314         }
 315
 316       break;
 317     }
 318
 319   return m;
 320 }
 321
 322
 323 /* Compare two typespecs, recursively if necessary.  */
 324
 325 int
 326 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
 327 {
 328   gfc_component *dt1, *dt2;
 329
 330   if (ts1->type != ts2->type)
 331     return 0;
 332   if (ts1->type != BT_DERIVED)
 333     return (ts1->kind == ts2->kind);
 334
 335   /* Compare derived types.  */
 336   if (ts1->derived == ts2->derived)
 337     return 1;
 338
 339   /* Special case for comparing derived types across namespaces.  If the
 340      true names and module names are the same and the module name is
 341      nonnull, then they are equal.  */
 342   if (strcmp (ts1->derived->name, ts2->derived->name) == 0
 343       && ((ts1->derived->module == NULL && ts2->derived->module == NULL)
 344           || (ts1->derived != NULL && ts2->derived != NULL
 345               && strcmp (ts1->derived->module, ts2->derived->module) == 0)))
 346     return 1;
 347
 348   /* Compare type via the rules of the standard.  Both types must have
 349      the SEQUENCE attribute to be equal.  */
 350
 351   if (strcmp (ts1->derived->name, ts2->derived->name))
 352     return 0;
 353
 354   dt1 = ts1->derived->components;
 355   dt2 = ts2->derived->components;
 356
 357   if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
 358     return 0;
 359
 360   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
 361      simple test can speed things up.  Otherwise, lots of things have to
 362      match.  */
 363   for (;;)
 364     {
 365       if (strcmp (dt1->name, dt2->name) != 0)
 366         return 0;
 367
 368       if (dt1->pointer != dt2->pointer)
 369         return 0;
 370
 371       if (dt1->dimension != dt2->dimension)
 372         return 0;
 373
 374       if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
 375         return 0;
 376
 377       if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
 378         return 0;
 379
 380       dt1 = dt1->next;
 381       dt2 = dt2->next;
 382
 383       if (dt1 == NULL && dt2 == NULL)
 384         break;
 385       if (dt1 == NULL || dt2 == NULL)
 386         return 0;
 387     }
 388
 389   return 1;
 390 }
 391
 392
 393 /* Given two symbols that are formal arguments, compare their ranks
 394    and types.  Returns nonzero if they have the same rank and type,
 395    zero otherwise.  */
 396
 397 static int
 398 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
 399 {
 400   int r1, r2;
 401
 402   r1 = (s1->as != NULL) ? s1->as->rank : 0;
 403   r2 = (s2->as != NULL) ? s2->as->rank : 0;
 404
 405   if (r1 != r2)
 406     return 0;                   /* Ranks differ */
 407
 408   return gfc_compare_types (&s1->ts, &s2->ts);
 409 }
 410
 411
 412 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
 413
 414 /* Given two symbols that are formal arguments, compare their types
 415    and rank and their formal interfaces if they are both dummy
 416    procedures.  Returns nonzero if the same, zero if different.  */
 417
 418 static int
 419 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
 420 {
 421
 422   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
 423     return compare_type_rank (s1, s2);
 424
 425   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
 426     return 0;
 427
 428   /* At this point, both symbols are procedures.  */
 429   if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
 430       || (s2->attr.function == 0 && s2->attr.subroutine == 0))
 431     return 0;
 432
 433   if (s1->attr.function != s2->attr.function
 434       || s1->attr.subroutine != s2->attr.subroutine)
 435     return 0;
 436
 437   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
 438     return 0;
 439
 440   return compare_interfaces (s1, s2, 0);        /* Recurse! */
 441 }
 442
 443
 444 /* Given a formal argument list and a keyword name, search the list
 445    for that keyword.  Returns the correct symbol node if found, NULL
 446    if not found.  */
 447
 448 static gfc_symbol *
 449 find_keyword_arg (const char *name, gfc_formal_arglist * f)
 450 {
 451
 452   for (; f; f = f->next)
 453     if (strcmp (f->sym->name, name) == 0)
 454       return f->sym;
 455
 456   return NULL;
 457 }
 458
 459
 460 /******** Interface checking subroutines **********/
 461
 462
 463 /* Given an operator interface and the operator, make sure that all
 464    interfaces for that operator are legal.  */
 465
 466 static void
 467 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
 468 {
 469   gfc_formal_arglist *formal;
 470   sym_intent i1, i2;
 471   gfc_symbol *sym;
 472   bt t1, t2;
 473   int args;
 474
 475   if (intr == NULL)
 476     return;
 477
 478   args = 0;
 479   t1 = t2 = BT_UNKNOWN;
 480   i1 = i2 = INTENT_UNKNOWN;
 481
 482   for (formal = intr->sym->formal; formal; formal = formal->next)
 483     {
 484       sym = formal->sym;
 485
 486       if (args == 0)
 487         {
 488           t1 = sym->ts.type;
 489           i1 = sym->attr.intent;
 490         }
 491       if (args == 1)
 492         {
 493           t2 = sym->ts.type;
 494           i2 = sym->attr.intent;
 495         }
 496       args++;
 497     }
 498
 499   if (args == 0 || args > 2)
 500     goto num_args;
 501
 502   sym = intr->sym;
 503
 504   if (operator == INTRINSIC_ASSIGN)
 505     {
 506       if (!sym->attr.subroutine)
 507         {
 508           gfc_error
 509             ("Assignment operator interface at %L must be a SUBROUTINE",
 510              &intr->where);
 511           return;
 512         }
 513     }
 514   else
 515     {
 516       if (!sym->attr.function)
 517         {
 518           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
 519                      &intr->where);
 520           return;
 521         }
 522     }
 523
 524   switch (operator)
 525     {
 526     case INTRINSIC_PLUS:        /* Numeric unary or binary */
 527     case INTRINSIC_MINUS:
 528       if ((args == 1)
 529           && (t1 == BT_INTEGER
 530               || t1 == BT_REAL
 531               || t1 == BT_COMPLEX))
 532         goto bad_repl;
 533
 534       if ((args == 2)
 535           && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
 536           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
 537         goto bad_repl;
 538
 539       break;
 540
 541     case INTRINSIC_POWER:       /* Binary numeric */
 542     case INTRINSIC_TIMES:
 543     case INTRINSIC_DIVIDE:
 544
 545     case INTRINSIC_EQ:
 546     case INTRINSIC_NE:
 547       if (args == 1)
 548         goto num_args;
 549
 550       if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
 551           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
 552         goto bad_repl;
 553
 554       break;
 555
 556     case INTRINSIC_GE:          /* Binary numeric operators that do not support */
 557     case INTRINSIC_LE:          /* complex numbers */
 558     case INTRINSIC_LT:
 559     case INTRINSIC_GT:
 560       if (args == 1)
 561         goto num_args;
 562
 563       if ((t1 == BT_INTEGER || t1 == BT_REAL)
 564           && (t2 == BT_INTEGER || t2 == BT_REAL))
 565         goto bad_repl;
 566
 567       break;
 568
 569     case INTRINSIC_OR:          /* Binary logical */
 570     case INTRINSIC_AND:
 571     case INTRINSIC_EQV:
 572     case INTRINSIC_NEQV:
 573       if (args == 1)
 574         goto num_args;
 575       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
 576         goto bad_repl;
 577       break;
 578
 579     case INTRINSIC_NOT: /* Unary logical */
 580       if (args != 1)
 581         goto num_args;
 582       if (t1 == BT_LOGICAL)
 583         goto bad_repl;
 584       break;
 585
 586     case INTRINSIC_CONCAT:      /* Binary string */
 587       if (args != 2)
 588         goto num_args;
 589       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 590         goto bad_repl;
 591       break;
 592
 593     case INTRINSIC_ASSIGN:      /* Class by itself */
 594       if (args != 2)
 595         goto num_args;
 596       break;
 597     default:
 598       gfc_internal_error ("check_operator_interface(): Bad operator");
 599     }
 600
 601   /* Check intents on operator interfaces.  */
 602   if (operator == INTRINSIC_ASSIGN)
 603     {
 604       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
 605         gfc_error ("First argument of defined assignment at %L must be "
 606                    "INTENT(IN) or INTENT(INOUT)", &intr->where);
 607
 608       if (i2 != INTENT_IN)
 609         gfc_error ("Second argument of defined assignment at %L must be "
 610                    "INTENT(IN)", &intr->where);
 611     }
 612   else
 613     {
 614       if (i1 != INTENT_IN)
 615         gfc_error ("First argument of operator interface at %L must be "
 616                    "INTENT(IN)", &intr->where);
 617
 618       if (args == 2 && i2 != INTENT_IN)
 619         gfc_error ("Second argument of operator interface at %L must be "
 620                    "INTENT(IN)", &intr->where);
 621     }
 622
 623   return;
 624
 625 bad_repl:
 626   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
 627              &intr->where);
 628   return;
 629
 630 num_args:
 631   gfc_error ("Operator interface at %L has the wrong number of arguments",
 632              &intr->where);
 633   return;
 634 }
 635
 636
 637 /* Given a pair of formal argument lists, we see if the two lists can
 638    be distinguished by counting the number of nonoptional arguments of
 639    a given type/rank in f1 and seeing if there are less then that
 640    number of those arguments in f2 (including optional arguments).
 641    Since this test is asymmetric, it has to be called twice to make it
 642    symmetric.  Returns nonzero if the argument lists are incompatible
 643    by this test.  This subroutine implements rule 1 of section
 644    14.1.2.3.  */
 645
 646 static int
 647 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 648 {
 649   int rc, ac1, ac2, i, j, k, n1;
 650   gfc_formal_arglist *f;
 651
 652   typedef struct
 653   {
 654     int flag;
 655     gfc_symbol *sym;
 656   }
 657   arginfo;
 658
 659   arginfo *arg;
 660
 661   n1 = 0;
 662
 663   for (f = f1; f; f = f->next)
 664     n1++;
 665
 666   /* Build an array of integers that gives the same integer to
 667      arguments of the same type/rank.  */
 668   arg = gfc_getmem (n1 * sizeof (arginfo));
 669
 670   f = f1;
 671   for (i = 0; i < n1; i++, f = f->next)
 672     {
 673       arg[i].flag = -1;
 674       arg[i].sym = f->sym;
 675     }
 676
 677   k = 0;
 678
 679   for (i = 0; i < n1; i++)
 680     {
 681       if (arg[i].flag != -1)
 682         continue;
 683
 684       if (arg[i].sym->attr.optional)
 685         continue;               /* Skip optional arguments */
 686
 687       arg[i].flag = k;
 688
 689       /* Find other nonoptional arguments of the same type/rank.  */
 690       for (j = i + 1; j < n1; j++)
 691         if (!arg[j].sym->attr.optional
 692             && compare_type_rank_if (arg[i].sym, arg[j].sym))
 693           arg[j].flag = k;
 694
 695       k++;
 696     }
 697
 698   /* Now loop over each distinct type found in f1.  */
 699   k = 0;
 700   rc = 0;
 701
 702   for (i = 0; i < n1; i++)
 703     {
 704       if (arg[i].flag != k)
 705         continue;
 706
 707       ac1 = 1;
 708       for (j = i + 1; j < n1; j++)
 709         if (arg[j].flag == k)
 710           ac1++;
 711
 712       /* Count the number of arguments in f2 with that type, including
 713          those that are optional.  */
 714       ac2 = 0;
 715
 716       for (f = f2; f; f = f->next)
 717         if (compare_type_rank_if (arg[i].sym, f->sym))
 718           ac2++;
 719
 720       if (ac1 > ac2)
 721         {
 722           rc = 1;
 723           break;
 724         }
 725
 726       k++;
 727     }
 728
 729   gfc_free (arg);
 730
 731   return rc;
 732 }
 733
 734
 735 /* Perform the abbreviated correspondence test for operators.  The
 736    arguments cannot be optional and are always ordered correctly,
 737    which makes this test much easier than that for generic tests.
 738
 739    This subroutine is also used when comparing a formal and actual
 740    argument list when an actual parameter is a dummy procedure.  At
 741    that point, two formal interfaces must be compared for equality
 742    which is what happens here.  */
 743
 744 static int
 745 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 746 {
 747   for (;;)
 748     {
 749       if (f1 == NULL && f2 == NULL)
 750         break;
 751       if (f1 == NULL || f2 == NULL)
 752         return 1;
 753
 754       if (!compare_type_rank (f1->sym, f2->sym))
 755         return 1;
 756
 757       f1 = f1->next;
 758       f2 = f2->next;
 759     }
 760
 761   return 0;
 762 }
 763
 764
 765 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
 766    Returns zero if no argument is found that satisfies rule 2, nonzero
 767    otherwise.
 768
 769    This test is also not symmetric in f1 and f2 and must be called
 770    twice.  This test finds problems caused by sorting the actual
 771    argument list with keywords.  For example:
 772
 773    INTERFACE FOO
 774        SUBROUTINE F1(A, B)
 775            INTEGER :: A ; REAL :: B
 776        END SUBROUTINE F1
 777
 778        SUBROUTINE F2(B, A)
 779            INTEGER :: A ; REAL :: B
 780        END SUBROUTINE F1
 781    END INTERFACE FOO
 782
 783    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
 784
 785 static int
 786 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 787 {
 788
 789   gfc_formal_arglist *f2_save, *g;
 790   gfc_symbol *sym;
 791
 792   f2_save = f2;
 793
 794   while (f1)
 795     {
 796       if (f1->sym->attr.optional)
 797         goto next;
 798
 799       if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
 800         goto next;
 801
 802       /* Now search for a disambiguating keyword argument starting at
 803          the current non-match.  */
 804       for (g = f1; g; g = g->next)
 805         {
 806           if (g->sym->attr.optional)
 807             continue;
 808
 809           sym = find_keyword_arg (g->sym->name, f2_save);
 810           if (sym == NULL || !compare_type_rank (g->sym, sym))
 811             return 1;
 812         }
 813
 814     next:
 815       f1 = f1->next;
 816       if (f2 != NULL)
 817         f2 = f2->next;
 818     }
 819
 820   return 0;
 821 }
 822
 823
 824 /* 'Compare' two formal interfaces associated with a pair of symbols.
 825    We return nonzero if there exists an actual argument list that
 826    would be ambiguous between the two interfaces, zero otherwise.  */
 827
 828 static int
 829 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
 830 {
 831   gfc_formal_arglist *f1, *f2;
 832
 833   if (s1->attr.function != s2->attr.function
 834       && s1->attr.subroutine != s2->attr.subroutine)
 835     return 0;                   /* disagreement between function/subroutine */
 836
 837   f1 = s1->formal;
 838   f2 = s2->formal;
 839
 840   if (f1 == NULL && f2 == NULL)
 841     return 1;                   /* Special case */
 842
 843   if (count_types_test (f1, f2))
 844     return 0;
 845   if (count_types_test (f2, f1))
 846     return 0;
 847
 848   if (generic_flag)
 849     {
 850       if (generic_correspondence (f1, f2))
 851         return 0;
 852       if (generic_correspondence (f2, f1))
 853         return 0;
 854     }
 855   else
 856     {
 857       if (operator_correspondence (f1, f2))
 858         return 0;
 859     }
 860
 861   return 1;
 862 }
 863
 864
 865 /* Given a pointer to an interface pointer, remove duplicate
 866    interfaces and make sure that all symbols are either functions or
 867    subroutines.  Returns nonzero if something goes wrong.  */
 868
 869 static int
 870 check_interface0 (gfc_interface * p, const char *interface_name)
 871 {
 872   gfc_interface *psave, *q, *qlast;
 873
 874   psave = p;
 875   /* Make sure all symbols in the interface have been defined as
 876      functions or subroutines.  */
 877   for (; p; p = p->next)
 878     if (!p->sym->attr.function && !p->sym->attr.subroutine)
 879       {
 880         gfc_error ("Procedure '%s' in %s at %L is neither function nor "
 881                    "subroutine", p->sym->name, interface_name,
 882                    &p->sym->declared_at);
 883         return 1;
 884       }
 885   p = psave;
 886
 887   /* Remove duplicate interfaces in this interface list.  */
 888   for (; p; p = p->next)
 889     {
 890       qlast = p;
 891
 892       for (q = p->next; q;)
 893         {
 894           if (p->sym != q->sym)
 895             {
 896               qlast = q;
 897               q = q->next;
 898
 899             }
 900           else
 901             {
 902               /* Duplicate interface */
 903               qlast->next = q->next;
 904               gfc_free (q);
 905               q = qlast->next;
 906             }
 907         }
 908     }
 909
 910   return 0;
 911 }
 912
 913
 914 /* Check lists of interfaces to make sure that no two interfaces are
 915    ambiguous.  Duplicate interfaces (from the same symbol) are OK
 916    here.  */
 917
 918 static int
 919 check_interface1 (gfc_interface * p, gfc_interface * q,
 920                   int generic_flag, const char *interface_name)
 921 {
 922
 923   for (; p; p = p->next)
 924     for (; q; q = q->next)
 925       {
 926         if (p->sym == q->sym)
 927           continue;             /* Duplicates OK here */
 928
 929         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 930           continue;
 931
 932         if (compare_interfaces (p->sym, q->sym, generic_flag))
 933           {
 934             gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
 935                        p->sym->name, q->sym->name, interface_name, &p->where);
 936             return 1;
 937           }
 938       }
 939
 940   return 0;
 941 }
 942
 943
 944 /* Check the generic and operator interfaces of symbols to make sure
 945    that none of the interfaces conflict.  The check has to be done
 946    after all of the symbols are actually loaded.  */
 947
 948 static void
 949 check_sym_interfaces (gfc_symbol * sym)
 950 {
 951   char interface_name[100];
 952   gfc_symbol *s2;
 953
 954   if (sym->ns != gfc_current_ns)
 955     return;
 956
 957   if (sym->generic != NULL)
 958     {
 959       sprintf (interface_name, "generic interface '%s'", sym->name);
 960       if (check_interface0 (sym->generic, interface_name))
 961         return;
 962
 963       s2 = sym;
 964       while (s2 != NULL)
 965         {
 966           if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
 967             return;
 968
 969           if (s2->ns->parent == NULL)
 970             break;
 971           if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
 972             break;
 973         }
 974     }
 975 }
 976
 977
 978 static void
 979 check_uop_interfaces (gfc_user_op * uop)
 980 {
 981   char interface_name[100];
 982   gfc_user_op *uop2;
 983   gfc_namespace *ns;
 984
 985   sprintf (interface_name, "operator interface '%s'", uop->name);
 986   if (check_interface0 (uop->operator, interface_name))
 987     return;
 988
 989   for (ns = gfc_current_ns; ns; ns = ns->parent)
 990     {
 991       uop2 = gfc_find_uop (uop->name, ns);
 992       if (uop2 == NULL)
 993         continue;
 994
 995       check_interface1 (uop->operator, uop2->operator, 0, interface_name);
 996     }
 997 }
 998
 999
1000 /* For the namespace, check generic, user operator and intrinsic
1001    operator interfaces for consistency and to remove duplicate
1002    interfaces.  We traverse the whole namespace, counting on the fact
1003    that most symbols will not have generic or operator interfaces.  */
1004
1005 void
1006 gfc_check_interfaces (gfc_namespace * ns)
1007 {
1008   gfc_namespace *old_ns, *ns2;
1009   char interface_name[100];
1010   gfc_intrinsic_op i;
1011
1012   old_ns = gfc_current_ns;
1013   gfc_current_ns = ns;
1014
1015   gfc_traverse_ns (ns, check_sym_interfaces);
1016
1017   gfc_traverse_user_op (ns, check_uop_interfaces);
1018
1019   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1020     {
1021       if (i == INTRINSIC_USER)
1022         continue;
1023
1024       if (i == INTRINSIC_ASSIGN)
1025         strcpy (interface_name, "intrinsic assignment operator");
1026       else
1027         sprintf (interface_name, "intrinsic '%s' operator",
1028                  gfc_op2string (i));
1029
1030       if (check_interface0 (ns->operator[i], interface_name))
1031         continue;
1032
1033       check_operator_interface (ns->operator[i], i);
1034
1035       for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1036         if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1037                               interface_name))
1038           break;
1039     }
1040
1041   gfc_current_ns = old_ns;
1042 }
1043
1044
1045 static int
1046 symbol_rank (gfc_symbol * sym)
1047 {
1048
1049   return (sym->as == NULL) ? 0 : sym->as->rank;
1050 }
1051
1052
1053 /* Given a symbol of a formal argument list and an expression, if the
1054    formal argument is a pointer, see if the actual argument is a
1055    pointer. Returns nonzero if compatible, zero if not compatible.  */
1056
1057 static int
1058 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1059 {
1060   symbol_attribute attr;
1061
1062   if (formal->attr.pointer)
1063     {
1064       attr = gfc_expr_attr (actual);
1065       if (!attr.pointer)
1066         return 0;
1067     }
1068
1069   return 1;
1070 }
1071
1072
1073 /* Given a symbol of a formal argument list and an expression, see if
1074    the two are compatible as arguments.  Returns nonzero if
1075    compatible, zero if not compatible.  */
1076
1077 static int
1078 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1079                    int ranks_must_agree, int is_elemental)
1080 {
1081   gfc_ref *ref;
1082
1083   if (actual->ts.type == BT_PROCEDURE)
1084     {
1085       if (formal->attr.flavor != FL_PROCEDURE)
1086         return 0;
1087
1088       if (formal->attr.function
1089           && !compare_type_rank (formal, actual->symtree->n.sym))
1090         return 0;
1091
1092       if (formal->attr.if_source == IFSRC_UNKNOWN)
1093         return 1;               /* Assume match */
1094
1095       return compare_interfaces (formal, actual->symtree->n.sym, 0);
1096     }
1097
1098   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1099       && !gfc_compare_types (&formal->ts, &actual->ts))
1100     return 0;
1101
1102   if (symbol_rank (formal) == actual->rank)
1103     return 1;
1104
1105   /* At this point the ranks didn't agree.  */
1106   if (ranks_must_agree || formal->attr.pointer)
1107     return 0;
1108
1109   if (actual->rank != 0)
1110     return is_elemental || formal->attr.dimension;
1111
1112   /* At this point, we are considering a scalar passed to an array.
1113      This is legal if the scalar is an array element of the right sort.  */
1114   if (formal->as->type == AS_ASSUMED_SHAPE)
1115     return 0;
1116
1117   for (ref = actual->ref; ref; ref = ref->next)
1118     if (ref->type == REF_SUBSTRING)
1119       return 0;
1120
1121   for (ref = actual->ref; ref; ref = ref->next)
1122     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1123       break;
1124
1125   if (ref == NULL)
1126     return 0;                   /* Not an array element */
1127
1128   return 1;
1129 }
1130
1131
1132 /* Given formal and actual argument lists, see if they are compatible.
1133    If they are compatible, the actual argument list is sorted to
1134    correspond with the formal list, and elements for missing optional
1135    arguments are inserted. If WHERE pointer is nonnull, then we issue
1136    errors when things don't match instead of just returning the status
1137    code.  */
1138
1139 static int
1140 compare_actual_formal (gfc_actual_arglist ** ap,
1141                        gfc_formal_arglist * formal,
1142                        int ranks_must_agree, int is_elemental, locus * where)
1143 {
1144   gfc_actual_arglist **new, *a, *actual, temp;
1145   gfc_formal_arglist *f;
1146   int i, n, na;
1147
1148   actual = *ap;
1149
1150   if (actual == NULL && formal == NULL)
1151     return 1;
1152
1153   n = 0;
1154   for (f = formal; f; f = f->next)
1155     n++;
1156
1157   new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1158
1159   for (i = 0; i < n; i++)
1160     new[i] = NULL;
1161
1162   na = 0;
1163   f = formal;
1164   i = 0;
1165
1166   for (a = actual; a; a = a->next, f = f->next)
1167     {
1168       if (a->name != NULL)
1169         {
1170           i = 0;
1171           for (f = formal; f; f = f->next, i++)
1172             {
1173               if (f->sym == NULL)
1174                 continue;
1175               if (strcmp (f->sym->name, a->name) == 0)
1176                 break;
1177             }
1178
1179           if (f == NULL)
1180             {
1181               if (where)
1182                 gfc_error
1183                   ("Keyword argument '%s' at %L is not in the procedure",
1184                    a->name, &a->expr->where);
1185               return 0;
1186             }
1187
1188           if (new[i] != NULL)
1189             {
1190               if (where)
1191                 gfc_error
1192                   ("Keyword argument '%s' at %L is already associated "
1193                    "with another actual argument", a->name, &a->expr->where);
1194               return 0;
1195             }
1196         }
1197
1198       if (f == NULL)
1199         {
1200           if (where)
1201             gfc_error
1202               ("More actual than formal arguments in procedure call at %L",
1203                where);
1204
1205           return 0;
1206         }
1207
1208       if (f->sym == NULL && a->expr == NULL)
1209         goto match;
1210
1211       if (f->sym == NULL)
1212         {
1213           if (where)
1214             gfc_error
1215               ("Missing alternate return spec in subroutine call at %L",
1216                where);
1217           return 0;
1218         }
1219
1220       if (a->expr == NULL)
1221         {
1222           if (where)
1223             gfc_error
1224               ("Unexpected alternate return spec in subroutine call at %L",
1225                where);
1226           return 0;
1227         }
1228
1229       if (!compare_parameter
1230           (f->sym, a->expr, ranks_must_agree, is_elemental))
1231         {
1232           if (where)
1233             gfc_error ("Type/rank mismatch in argument '%s' at %L",
1234                        f->sym->name, &a->expr->where);
1235           return 0;
1236         }
1237
1238       if (f->sym->as
1239           && f->sym->as->type == AS_ASSUMED_SHAPE
1240           && a->expr->expr_type == EXPR_VARIABLE
1241           && a->expr->symtree->n.sym->as
1242           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1243           && (a->expr->ref == NULL
1244               || (a->expr->ref->type == REF_ARRAY
1245                   && a->expr->ref->u.ar.type == AR_FULL)))
1246         {
1247           if (where)
1248             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1249                        " array at %L", f->sym->name, where);
1250           return 0;
1251         }
1252
1253       if (a->expr->expr_type != EXPR_NULL
1254           && compare_pointer (f->sym, a->expr) == 0)
1255         {
1256           if (where)
1257             gfc_error ("Actual argument for '%s' must be a pointer at %L",
1258                        f->sym->name, &a->expr->where);
1259           return 0;
1260         }
1261
1262     match:
1263       if (a == actual)
1264         na = i;
1265
1266       new[i++] = a;
1267     }
1268
1269   /* Make sure missing actual arguments are optional.  */
1270   i = 0;
1271   for (f = formal; f; f = f->next, i++)
1272     {
1273       if (new[i] != NULL)
1274         continue;
1275       if (!f->sym->attr.optional)
1276         {
1277           if (where)
1278             gfc_error ("Missing actual argument for argument '%s' at %L",
1279                        f->sym->name, where);
1280           return 0;
1281         }
1282     }
1283
1284   /* The argument lists are compatible.  We now relink a new actual
1285      argument list with null arguments in the right places.  The head
1286      of the list remains the head.  */
1287   for (i = 0; i < n; i++)
1288     if (new[i] == NULL)
1289       new[i] = gfc_get_actual_arglist ();
1290
1291   if (na != 0)
1292     {
1293       temp = *new[0];
1294       *new[0] = *actual;
1295       *actual = temp;
1296
1297       a = new[0];
1298       new[0] = new[na];
1299       new[na] = a;
1300     }
1301
1302   for (i = 0; i < n - 1; i++)
1303     new[i]->next = new[i + 1];
1304
1305   new[i]->next = NULL;
1306
1307   if (*ap == NULL && n > 0)
1308     *ap = new[0];
1309
1310   /* Note the types of omitted optional arguments.  */
1311   for (a = actual, f = formal; a; a = a->next, f = f->next)
1312     if (a->expr == NULL && a->label == NULL)
1313       a->missing_arg_type = f->sym->ts.type;
1314
1315   return 1;
1316 }
1317
1318
1319 typedef struct
1320 {
1321   gfc_formal_arglist *f;
1322   gfc_actual_arglist *a;
1323 }
1324 argpair;
1325
1326 /* qsort comparison function for argument pairs, with the following
1327    order:
1328     - p->a->expr == NULL
1329     - p->a->expr->expr_type != EXPR_VARIABLE
1330     - growing p->a->expr->symbol.  */
1331
1332 static int
1333 pair_cmp (const void *p1, const void *p2)
1334 {
1335   const gfc_actual_arglist *a1, *a2;
1336
1337   /* *p1 and *p2 are elements of the to-be-sorted array.  */
1338   a1 = ((const argpair *) p1)->a;
1339   a2 = ((const argpair *) p2)->a;
1340   if (!a1->expr)
1341     {
1342       if (!a2->expr)
1343         return 0;
1344       return -1;
1345     }
1346   if (!a2->expr)
1347     return 1;
1348   if (a1->expr->expr_type != EXPR_VARIABLE)
1349     {
1350       if (a2->expr->expr_type != EXPR_VARIABLE)
1351         return 0;
1352       return -1;
1353     }
1354   if (a2->expr->expr_type != EXPR_VARIABLE)
1355     return 1;
1356   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1357 }
1358
1359
1360 /* Given two expressions from some actual arguments, test whether they
1361    refer to the same expression. The analysis is conservative.
1362    Returning FAILURE will produce no warning.  */
1363
1364 static try
1365 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1366 {
1367   const gfc_ref *r1, *r2;
1368
1369   if (!e1 || !e2
1370       || e1->expr_type != EXPR_VARIABLE
1371       || e2->expr_type != EXPR_VARIABLE
1372       || e1->symtree->n.sym != e2->symtree->n.sym)
1373     return FAILURE;
1374
1375   /* TODO: improve comparison, see expr.c:show_ref().  */
1376   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1377     {
1378       if (r1->type != r2->type)
1379         return FAILURE;
1380       switch (r1->type)
1381         {
1382         case REF_ARRAY:
1383           if (r1->u.ar.type != r2->u.ar.type)
1384             return FAILURE;
1385           /* TODO: At the moment, consider only full arrays;
1386              we could do better.  */
1387           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1388             return FAILURE;
1389           break;
1390
1391         case REF_COMPONENT:
1392           if (r1->u.c.component != r2->u.c.component)
1393             return FAILURE;
1394           break;
1395
1396         case REF_SUBSTRING:
1397           return FAILURE;
1398
1399         default:
1400           gfc_internal_error ("compare_actual_expr(): Bad component code");
1401         }
1402     }
1403   if (!r1 && !r2)
1404     return SUCCESS;
1405   return FAILURE;
1406 }
1407
1408 /* Given formal and actual argument lists that correspond to one
1409    another, check that identical actual arguments aren't not
1410    associated with some incompatible INTENTs.  */
1411
1412 static try
1413 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1414 {
1415   sym_intent f1_intent, f2_intent;
1416   gfc_formal_arglist *f1;
1417   gfc_actual_arglist *a1;
1418   size_t n, i, j;
1419   argpair *p;
1420   try t = SUCCESS;
1421
1422   n = 0;
1423   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1424     {
1425       if (f1 == NULL && a1 == NULL)
1426         break;
1427       if (f1 == NULL || a1 == NULL)
1428         gfc_internal_error ("check_some_aliasing(): List mismatch");
1429       n++;
1430     }
1431   if (n == 0)
1432     return t;
1433   p = (argpair *) alloca (n * sizeof (argpair));
1434
1435   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1436     {
1437       p[i].f = f1;
1438       p[i].a = a1;
1439     }
1440
1441   qsort (p, n, sizeof (argpair), pair_cmp);
1442
1443   for (i = 0; i < n; i++)
1444     {
1445       if (!p[i].a->expr
1446           || p[i].a->expr->expr_type != EXPR_VARIABLE
1447           || p[i].a->expr->ts.type == BT_PROCEDURE)
1448         continue;
1449       f1_intent = p[i].f->sym->attr.intent;
1450       for (j = i + 1; j < n; j++)
1451         {
1452           /* Expected order after the sort.  */
1453           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1454             gfc_internal_error ("check_some_aliasing(): corrupted data");
1455
1456           /* Are the expression the same?  */
1457           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1458             break;
1459           f2_intent = p[j].f->sym->attr.intent;
1460           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1461               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1462             {
1463               gfc_warning ("Same actual argument associated with INTENT(%s) "
1464                            "argument '%s' and INTENT(%s) argument '%s' at %L",
1465                            gfc_intent_string (f1_intent), p[i].f->sym->name,
1466                            gfc_intent_string (f2_intent), p[j].f->sym->name,
1467                            &p[i].a->expr->where);
1468               t = FAILURE;
1469             }
1470         }
1471     }
1472
1473   return t;
1474 }
1475
1476
1477 /* Given formal and actual argument lists that correspond to one
1478    another, check that they are compatible in the sense that intents
1479    are not mismatched.  */
1480
1481 static try
1482 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1483 {
1484   sym_intent a_intent, f_intent;
1485
1486   for (;; f = f->next, a = a->next)
1487     {
1488       if (f == NULL && a == NULL)
1489         break;
1490       if (f == NULL || a == NULL)
1491         gfc_internal_error ("check_intents(): List mismatch");
1492
1493       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1494         continue;
1495
1496       a_intent = a->expr->symtree->n.sym->attr.intent;
1497       f_intent = f->sym->attr.intent;
1498
1499       if (a_intent == INTENT_IN
1500           && (f_intent == INTENT_INOUT
1501               || f_intent == INTENT_OUT))
1502         {
1503
1504           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1505                      "specifies INTENT(%s)", &a->expr->where,
1506                      gfc_intent_string (f_intent));
1507           return FAILURE;
1508         }
1509
1510       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1511         {
1512           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1513             {
1514               gfc_error
1515                 ("Procedure argument at %L is local to a PURE procedure and "
1516                  "is passed to an INTENT(%s) argument", &a->expr->where,
1517                  gfc_intent_string (f_intent));
1518               return FAILURE;
1519             }
1520
1521           if (a->expr->symtree->n.sym->attr.pointer)
1522             {
1523               gfc_error
1524                 ("Procedure argument at %L is local to a PURE procedure and "
1525                  "has the POINTER attribute", &a->expr->where);
1526               return FAILURE;
1527             }
1528         }
1529     }
1530
1531   return SUCCESS;
1532 }
1533
1534
1535 /* Check how a procedure is used against its interface.  If all goes
1536    well, the actual argument list will also end up being properly
1537    sorted.  */
1538
1539 void
1540 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1541 {
1542   /* Warn about calls with an implicit interface.  */
1543   if (gfc_option.warn_implicit_interface
1544       && sym->attr.if_source == IFSRC_UNKNOWN)
1545     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1546                  sym->name, where);
1547
1548   if (sym->attr.if_source == IFSRC_UNKNOWN
1549       || !compare_actual_formal (ap, sym->formal, 0,
1550                                  sym->attr.elemental, where))
1551     return;
1552
1553   check_intents (sym->formal, *ap);
1554   if (gfc_option.warn_aliasing)
1555     check_some_aliasing (sym->formal, *ap);
1556 }
1557
1558
1559 /* Given an interface pointer and an actual argument list, search for
1560    a formal argument list that matches the actual.  If found, returns
1561    a pointer to the symbol of the correct interface.  Returns NULL if
1562    not found.  */
1563
1564 gfc_symbol *
1565 gfc_search_interface (gfc_interface * intr, int sub_flag,
1566                       gfc_actual_arglist ** ap)
1567 {
1568   int r;
1569
1570   for (; intr; intr = intr->next)
1571     {
1572       if (sub_flag && intr->sym->attr.function)
1573         continue;
1574       if (!sub_flag && intr->sym->attr.subroutine)
1575         continue;
1576
1577       r = !intr->sym->attr.elemental;
1578
1579       if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1580         {
1581           check_intents (intr->sym->formal, *ap);
1582           if (gfc_option.warn_aliasing)
1583             check_some_aliasing (intr->sym->formal, *ap);
1584           return intr->sym;
1585         }
1586     }
1587
1588   return NULL;
1589 }
1590
1591
1592 /* Do a brute force recursive search for a symbol.  */
1593
1594 static gfc_symtree *
1595 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1596 {
1597   gfc_symtree * st;
1598
1599   if (root->n.sym == sym)
1600     return root;
1601
1602   st = NULL;
1603   if (root->left)
1604     st = find_symtree0 (root->left, sym);
1605   if (root->right && ! st)
1606     st = find_symtree0 (root->right, sym);
1607   return st;
1608 }
1609
1610
1611 /* Find a symtree for a symbol.  */
1612
1613 static gfc_symtree *
1614 find_sym_in_symtree (gfc_symbol * sym)
1615 {
1616   gfc_symtree *st;
1617   gfc_namespace *ns;
1618
1619   /* First try to find it by name.  */
1620   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1621   if (st && st->n.sym == sym)
1622     return st;
1623
1624   /* if it's been renamed, resort to a brute-force search.  */
1625   /* TODO: avoid having to do this search.  If the symbol doesn't exist
1626      in the symtree for the current namespace, it should probably be added.  */
1627   for (ns = gfc_current_ns; ns; ns = ns->parent)
1628     {
1629       st = find_symtree0 (ns->sym_root, sym);
1630       if (st)
1631         return st;
1632     }
1633   gfc_internal_error ("Unable to find symbol %s", sym->name);
1634   /* Not reached */
1635 }
1636
1637
1638 /* This subroutine is called when an expression is being resolved.
1639    The expression node in question is either a user defined operator
1640    or an intrinsic operator with arguments that aren't compatible
1641    with the operator.  This subroutine builds an actual argument list
1642    corresponding to the operands, then searches for a compatible
1643    interface.  If one is found, the expression node is replaced with
1644    the appropriate function call.  */
1645
1646 try
1647 gfc_extend_expr (gfc_expr * e)
1648 {
1649   gfc_actual_arglist *actual;
1650   gfc_symbol *sym;
1651   gfc_namespace *ns;
1652   gfc_user_op *uop;
1653   gfc_intrinsic_op i;
1654
1655   sym = NULL;
1656
1657   actual = gfc_get_actual_arglist ();
1658   actual->expr = e->value.op.op1;
1659
1660   if (e->value.op.op2 != NULL)
1661     {
1662       actual->next = gfc_get_actual_arglist ();
1663       actual->next->expr = e->value.op.op2;
1664     }
1665
1666   i = fold_unary (e->value.op.operator);
1667
1668   if (i == INTRINSIC_USER)
1669     {
1670       for (ns = gfc_current_ns; ns; ns = ns->parent)
1671         {
1672           uop = gfc_find_uop (e->value.op.uop->name, ns);
1673           if (uop == NULL)
1674             continue;
1675
1676           sym = gfc_search_interface (uop->operator, 0, &actual);
1677           if (sym != NULL)
1678             break;
1679         }
1680     }
1681   else
1682     {
1683       for (ns = gfc_current_ns; ns; ns = ns->parent)
1684         {
1685           sym = gfc_search_interface (ns->operator[i], 0, &actual);
1686           if (sym != NULL)
1687             break;
1688         }
1689     }
1690
1691   if (sym == NULL)
1692     {
1693       /* Don't use gfc_free_actual_arglist() */
1694       if (actual->next != NULL)
1695         gfc_free (actual->next);
1696       gfc_free (actual);
1697
1698       return FAILURE;
1699     }
1700
1701   /* Change the expression node to a function call.  */
1702   e->expr_type = EXPR_FUNCTION;
1703   e->symtree = find_sym_in_symtree (sym);
1704   e->value.function.actual = actual;
1705   e->value.function.esym = NULL;
1706   e->value.function.isym = NULL;
1707
1708   if (gfc_pure (NULL) && !gfc_pure (sym))
1709     {
1710       gfc_error
1711         ("Function '%s' called in lieu of an operator at %L must be PURE",
1712          sym->name, &e->where);
1713       return FAILURE;
1714     }
1715
1716   if (gfc_resolve_expr (e) == FAILURE)
1717     return FAILURE;
1718
1719   return SUCCESS;
1720 }
1721
1722
1723 /* Tries to replace an assignment code node with a subroutine call to
1724    the subroutine associated with the assignment operator.  Return
1725    SUCCESS if the node was replaced.  On FAILURE, no error is
1726    generated.  */
1727
1728 try
1729 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1730 {
1731   gfc_actual_arglist *actual;
1732   gfc_expr *lhs, *rhs;
1733   gfc_symbol *sym;
1734
1735   lhs = c->expr;
1736   rhs = c->expr2;
1737
1738   /* Don't allow an intrinsic assignment to be replaced.  */
1739   if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1740       && (lhs->ts.type == rhs->ts.type
1741           || (gfc_numeric_ts (&lhs->ts)
1742               && gfc_numeric_ts (&rhs->ts))))
1743     return FAILURE;
1744
1745   actual = gfc_get_actual_arglist ();
1746   actual->expr = lhs;
1747
1748   actual->next = gfc_get_actual_arglist ();
1749   actual->next->expr = rhs;
1750
1751   sym = NULL;
1752
1753   for (; ns; ns = ns->parent)
1754     {
1755       sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1756       if (sym != NULL)
1757         break;
1758     }
1759
1760   if (sym == NULL)
1761     {
1762       gfc_free (actual->next);
1763       gfc_free (actual);
1764       return FAILURE;
1765     }
1766
1767   /* Replace the assignment with the call.  */
1768   c->op = EXEC_CALL;
1769   c->symtree = find_sym_in_symtree (sym);
1770   c->expr = NULL;
1771   c->expr2 = NULL;
1772   c->ext.actual = actual;
1773
1774   if (gfc_pure (NULL) && !gfc_pure (sym))
1775     {
1776       gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
1777                  "PURE", sym->name, &c->loc);
1778       return FAILURE;
1779     }
1780
1781   return SUCCESS;
1782 }
1783
1784
1785 /* Make sure that the interface just parsed is not already present in
1786    the given interface list.  Ambiguity isn't checked yet since module
1787    procedures can be present without interfaces.  */
1788
1789 static try
1790 check_new_interface (gfc_interface * base, gfc_symbol * new)
1791 {
1792   gfc_interface *ip;
1793
1794   for (ip = base; ip; ip = ip->next)
1795     {
1796       if (ip->sym == new)
1797         {
1798           gfc_error ("Entity '%s' at %C is already present in the interface",
1799                      new->name);
1800           return FAILURE;
1801         }
1802     }
1803
1804   return SUCCESS;
1805 }
1806
1807
1808 /* Add a symbol to the current interface.  */
1809
1810 try
1811 gfc_add_interface (gfc_symbol * new)
1812 {
1813   gfc_interface **head, *intr;
1814   gfc_namespace *ns;
1815   gfc_symbol *sym;
1816
1817   switch (current_interface.type)
1818     {
1819     case INTERFACE_NAMELESS:
1820       return SUCCESS;
1821
1822     case INTERFACE_INTRINSIC_OP:
1823       for (ns = current_interface.ns; ns; ns = ns->parent)
1824         if (check_new_interface (ns->operator[current_interface.op], new)
1825             == FAILURE)
1826           return FAILURE;
1827
1828       head = &current_interface.ns->operator[current_interface.op];
1829       break;
1830
1831     case INTERFACE_GENERIC:
1832       for (ns = current_interface.ns; ns; ns = ns->parent)
1833         {
1834           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1835           if (sym == NULL)
1836             continue;
1837
1838           if (check_new_interface (sym->generic, new) == FAILURE)
1839             return FAILURE;
1840         }
1841
1842       head = &current_interface.sym->generic;
1843       break;
1844
1845     case INTERFACE_USER_OP:
1846       if (check_new_interface (current_interface.uop->operator, new) ==
1847           FAILURE)
1848         return FAILURE;
1849
1850       head = &current_interface.uop->operator;
1851       break;
1852
1853     default:
1854       gfc_internal_error ("gfc_add_interface(): Bad interface type");
1855     }
1856
1857   intr = gfc_get_interface ();
1858   intr->sym = new;
1859   intr->where = gfc_current_locus;
1860
1861   intr->next = *head;
1862   *head = intr;
1863
1864   return SUCCESS;
1865 }
1866
1867
1868 /* Gets rid of a formal argument list.  We do not free symbols.
1869    Symbols are freed when a namespace is freed.  */
1870
1871 void
1872 gfc_free_formal_arglist (gfc_formal_arglist * p)
1873 {
1874   gfc_formal_arglist *q;
1875
1876   for (; p; p = q)
1877     {
1878       q = p->next;
1879       gfc_free (p);
1880     }
1881 }