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