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
 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.sym->name, name) != 0)
 299         {
 300           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
 301                      current_interface.sym->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[0] != '\0'
 344       && strcmp (ts1->derived->module, ts2->derived->module) == 0)
 345     return 1;
 346
 347   /* Compare type via the rules of the standard.  Both types must have
 348      the SEQUENCE attribute to be equal.  */
 349
 350   if (strcmp (ts1->derived->name, ts2->derived->name))
 351     return 0;
 352
 353   dt1 = ts1->derived->components;
 354   dt2 = ts2->derived->components;
 355
 356   if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
 357     return 0;
 358
 359   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
 360      simple test can speed things up.  Otherwise, lots of things have to
 361      match.  */
 362   for (;;)
 363     {
 364       if (strcmp (dt1->name, dt2->name) != 0)
 365         return 0;
 366
 367       if (dt1->pointer != dt2->pointer)
 368         return 0;
 369
 370       if (dt1->dimension != dt2->dimension)
 371         return 0;
 372
 373       if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
 374         return 0;
 375
 376       if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
 377         return 0;
 378
 379       dt1 = dt1->next;
 380       dt2 = dt2->next;
 381
 382       if (dt1 == NULL && dt2 == NULL)
 383         break;
 384       if (dt1 == NULL || dt2 == NULL)
 385         return 0;
 386     }
 387
 388   return 1;
 389 }
 390
 391
 392 /* Given two symbols that are formal arguments, compare their ranks
 393    and types.  Returns nonzero if they have the same rank and type,
 394    zero otherwise.  */
 395
 396 static int
 397 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
 398 {
 399   int r1, r2;
 400
 401   r1 = (s1->as != NULL) ? s1->as->rank : 0;
 402   r2 = (s2->as != NULL) ? s2->as->rank : 0;
 403
 404   if (r1 != r2)
 405     return 0;                   /* Ranks differ */
 406
 407   return gfc_compare_types (&s1->ts, &s2->ts);
 408 }
 409
 410
 411 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
 412
 413 /* Given two symbols that are formal arguments, compare their types
 414    and rank and their formal interfaces if they are both dummy
 415    procedures.  Returns nonzero if the same, zero if different.  */
 416
 417 static int
 418 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
 419 {
 420
 421   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
 422     return compare_type_rank (s1, s2);
 423
 424   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
 425     return 0;
 426
 427   /* At this point, both symbols are procedures.  */
 428   if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
 429       || (s2->attr.function == 0 && s2->attr.subroutine == 0))
 430     return 0;
 431
 432   if (s1->attr.function != s2->attr.function
 433       || s1->attr.subroutine != s2->attr.subroutine)
 434     return 0;
 435
 436   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
 437     return 0;
 438
 439   return compare_interfaces (s1, s2, 0);        /* Recurse! */
 440 }
 441
 442
 443 /* Given a formal argument list and a keyword name, search the list
 444    for that keyword.  Returns the correct symbol node if found, NULL
 445    if not found.  */
 446
 447 static gfc_symbol *
 448 find_keyword_arg (const char *name, gfc_formal_arglist * f)
 449 {
 450
 451   for (; f; f = f->next)
 452     if (strcmp (f->sym->name, name) == 0)
 453       return f->sym;
 454
 455   return NULL;
 456 }
 457
 458
 459 /******** Interface checking subroutines **********/
 460
 461
 462 /* Given an operator interface and the operator, make sure that all
 463    interfaces for that operator are legal.  */
 464
 465 static void
 466 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
 467 {
 468   gfc_formal_arglist *formal;
 469   sym_intent i1, i2;
 470   gfc_symbol *sym;
 471   bt t1, t2;
 472   int args;
 473
 474   if (intr == NULL)
 475     return;
 476
 477   args = 0;
 478   t1 = t2 = BT_UNKNOWN;
 479   i1 = i2 = INTENT_UNKNOWN;
 480
 481   for (formal = intr->sym->formal; formal; formal = formal->next)
 482     {
 483       sym = formal->sym;
 484
 485       if (args == 0)
 486         {
 487           t1 = sym->ts.type;
 488           i1 = sym->attr.intent;
 489         }
 490       if (args == 1)
 491         {
 492           t2 = sym->ts.type;
 493           i2 = sym->attr.intent;
 494         }
 495       args++;
 496     }
 497
 498   if (args == 0 || args > 2)
 499     goto num_args;
 500
 501   sym = intr->sym;
 502
 503   if (operator == INTRINSIC_ASSIGN)
 504     {
 505       if (!sym->attr.subroutine)
 506         {
 507           gfc_error
 508             ("Assignment operator interface at %L must be a SUBROUTINE",
 509              &intr->where);
 510           return;
 511         }
 512     }
 513   else
 514     {
 515       if (!sym->attr.function)
 516         {
 517           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
 518                      &intr->where);
 519           return;
 520         }
 521     }
 522
 523   switch (operator)
 524     {
 525     case INTRINSIC_PLUS:        /* Numeric unary or binary */
 526     case INTRINSIC_MINUS:
 527       if ((args == 1)
 528           && (t1 == BT_INTEGER
 529               || t1 == BT_REAL
 530               || t1 == BT_COMPLEX))
 531         goto bad_repl;
 532
 533       if ((args == 2)
 534           && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
 535           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
 536         goto bad_repl;
 537
 538       break;
 539
 540     case INTRINSIC_POWER:       /* Binary numeric */
 541     case INTRINSIC_TIMES:
 542     case INTRINSIC_DIVIDE:
 543
 544     case INTRINSIC_EQ:
 545     case INTRINSIC_NE:
 546       if (args == 1)
 547         goto num_args;
 548
 549       if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
 550           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
 551         goto bad_repl;
 552
 553       break;
 554
 555     case INTRINSIC_GE:          /* Binary numeric operators that do not support */
 556     case INTRINSIC_LE:          /* complex numbers */
 557     case INTRINSIC_LT:
 558     case INTRINSIC_GT:
 559       if (args == 1)
 560         goto num_args;
 561
 562       if ((t1 == BT_INTEGER || t1 == BT_REAL)
 563           && (t2 == BT_INTEGER || t2 == BT_REAL))
 564         goto bad_repl;
 565
 566       break;
 567
 568     case INTRINSIC_OR:          /* Binary logical */
 569     case INTRINSIC_AND:
 570     case INTRINSIC_EQV:
 571     case INTRINSIC_NEQV:
 572       if (args == 1)
 573         goto num_args;
 574       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
 575         goto bad_repl;
 576       break;
 577
 578     case INTRINSIC_NOT: /* Unary logical */
 579       if (args != 1)
 580         goto num_args;
 581       if (t1 == BT_LOGICAL)
 582         goto bad_repl;
 583       break;
 584
 585     case INTRINSIC_CONCAT:      /* Binary string */
 586       if (args != 2)
 587         goto num_args;
 588       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
 589         goto bad_repl;
 590       break;
 591
 592     case INTRINSIC_ASSIGN:      /* Class by itself */
 593       if (args != 2)
 594         goto num_args;
 595       break;
 596     default:
 597       gfc_internal_error ("check_operator_interface(): Bad operator");
 598     }
 599
 600   /* Check intents on operator interfaces.  */
 601   if (operator == INTRINSIC_ASSIGN)
 602     {
 603       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
 604         gfc_error ("First argument of defined assignment at %L must be "
 605                    "INTENT(IN) or INTENT(INOUT)", &intr->where);
 606
 607       if (i2 != INTENT_IN)
 608         gfc_error ("Second argument of defined assignment at %L must be "
 609                    "INTENT(IN)", &intr->where);
 610     }
 611   else
 612     {
 613       if (i1 != INTENT_IN)
 614         gfc_error ("First argument of operator interface at %L must be "
 615                    "INTENT(IN)", &intr->where);
 616
 617       if (args == 2 && i2 != INTENT_IN)
 618         gfc_error ("Second argument of operator interface at %L must be "
 619                    "INTENT(IN)", &intr->where);
 620     }
 621
 622   return;
 623
 624 bad_repl:
 625   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
 626              &intr->where);
 627   return;
 628
 629 num_args:
 630   gfc_error ("Operator interface at %L has the wrong number of arguments",
 631              &intr->where);
 632   return;
 633 }
 634
 635
 636 /* Given a pair of formal argument lists, we see if the two lists can
 637    be distinguished by counting the number of nonoptional arguments of
 638    a given type/rank in f1 and seeing if there are less then that
 639    number of those arguments in f2 (including optional arguments).
 640    Since this test is asymmetric, it has to be called twice to make it
 641    symmetric.  Returns nonzero if the argument lists are incompatible
 642    by this test.  This subroutine implements rule 1 of section
 643    14.1.2.3.  */
 644
 645 static int
 646 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 647 {
 648   int rc, ac1, ac2, i, j, k, n1;
 649   gfc_formal_arglist *f;
 650
 651   typedef struct
 652   {
 653     int flag;
 654     gfc_symbol *sym;
 655   }
 656   arginfo;
 657
 658   arginfo *arg;
 659
 660   n1 = 0;
 661
 662   for (f = f1; f; f = f->next)
 663     n1++;
 664
 665   /* Build an array of integers that gives the same integer to
 666      arguments of the same type/rank.  */
 667   arg = gfc_getmem (n1 * sizeof (arginfo));
 668
 669   f = f1;
 670   for (i = 0; i < n1; i++, f = f->next)
 671     {
 672       arg[i].flag = -1;
 673       arg[i].sym = f->sym;
 674     }
 675
 676   k = 0;
 677
 678   for (i = 0; i < n1; i++)
 679     {
 680       if (arg[i].flag != -1)
 681         continue;
 682
 683       if (arg[i].sym->attr.optional)
 684         continue;               /* Skip optional arguments */
 685
 686       arg[i].flag = k;
 687
 688       /* Find other nonoptional arguments of the same type/rank.  */
 689       for (j = i + 1; j < n1; j++)
 690         if (!arg[j].sym->attr.optional
 691             && compare_type_rank_if (arg[i].sym, arg[j].sym))
 692           arg[j].flag = k;
 693
 694       k++;
 695     }
 696
 697   /* Now loop over each distinct type found in f1.  */
 698   k = 0;
 699   rc = 0;
 700
 701   for (i = 0; i < n1; i++)
 702     {
 703       if (arg[i].flag != k)
 704         continue;
 705
 706       ac1 = 1;
 707       for (j = i + 1; j < n1; j++)
 708         if (arg[j].flag == k)
 709           ac1++;
 710
 711       /* Count the number of arguments in f2 with that type, including
 712          those that are optional.  */
 713       ac2 = 0;
 714
 715       for (f = f2; f; f = f->next)
 716         if (compare_type_rank_if (arg[i].sym, f->sym))
 717           ac2++;
 718
 719       if (ac1 > ac2)
 720         {
 721           rc = 1;
 722           break;
 723         }
 724
 725       k++;
 726     }
 727
 728   gfc_free (arg);
 729
 730   return rc;
 731 }
 732
 733
 734 /* Perform the abbreviated correspondence test for operators.  The
 735    arguments cannot be optional and are always ordered correctly,
 736    which makes this test much easier than that for generic tests.
 737
 738    This subroutine is also used when comparing a formal and actual
 739    argument list when an actual parameter is a dummy procedure.  At
 740    that point, two formal interfaces must be compared for equality
 741    which is what happens here.  */
 742
 743 static int
 744 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 745 {
 746   for (;;)
 747     {
 748       if (f1 == NULL && f2 == NULL)
 749         break;
 750       if (f1 == NULL || f2 == NULL)
 751         return 1;
 752
 753       if (!compare_type_rank (f1->sym, f2->sym))
 754         return 1;
 755
 756       f1 = f1->next;
 757       f2 = f2->next;
 758     }
 759
 760   return 0;
 761 }
 762
 763
 764 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
 765    Returns zero if no argument is found that satisifes rule 2, nonzero
 766    otherwise.
 767
 768    This test is also not symmetric in f1 and f2 and must be called
 769    twice.  This test finds problems caused by sorting the actual
 770    argument list with keywords.  For example:
 771
 772    INTERFACE FOO
 773        SUBROUTINE F1(A, B)
 774            INTEGER :: A ; REAL :: B
 775        END SUBROUTINE F1
 776
 777        SUBROUTINE F2(B, A)
 778            INTEGER :: A ; REAL :: B
 779        END SUBROUTINE F1
 780    END INTERFACE FOO
 781
 782    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
 783
 784 static int
 785 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
 786 {
 787
 788   gfc_formal_arglist *f2_save, *g;
 789   gfc_symbol *sym;
 790
 791   f2_save = f2;
 792
 793   while (f1)
 794     {
 795       if (f1->sym->attr.optional)
 796         goto next;
 797
 798       if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
 799         goto next;
 800
 801       /* Now search for a disambiguating keyword argument starting at
 802          the current non-match.  */
 803       for (g = f1; g; g = g->next)
 804         {
 805           if (g->sym->attr.optional)
 806             continue;
 807
 808           sym = find_keyword_arg (g->sym->name, f2_save);
 809           if (sym == NULL || !compare_type_rank (g->sym, sym))
 810             return 1;
 811         }
 812
 813     next:
 814       f1 = f1->next;
 815       if (f2 != NULL)
 816         f2 = f2->next;
 817     }
 818
 819   return 0;
 820 }
 821
 822
 823 /* 'Compare' two formal interfaces associated with a pair of symbols.
 824    We return nonzero if there exists an actual argument list that
 825    would be ambiguous between the two interfaces, zero otherwise.  */
 826
 827 static int
 828 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
 829 {
 830   gfc_formal_arglist *f1, *f2;
 831
 832   if (s1->attr.function != s2->attr.function
 833       && s1->attr.subroutine != s2->attr.subroutine)
 834     return 0;                   /* disagreement between function/subroutine */
 835
 836   f1 = s1->formal;
 837   f2 = s2->formal;
 838
 839   if (f1 == NULL && f2 == NULL)
 840     return 1;                   /* Special case */
 841
 842   if (count_types_test (f1, f2))
 843     return 0;
 844   if (count_types_test (f2, f1))
 845     return 0;
 846
 847   if (generic_flag)
 848     {
 849       if (generic_correspondence (f1, f2))
 850         return 0;
 851       if (generic_correspondence (f2, f1))
 852         return 0;
 853     }
 854   else
 855     {
 856       if (operator_correspondence (f1, f2))
 857         return 0;
 858     }
 859
 860   return 1;
 861 }
 862
 863
 864 /* Given a pointer to an interface pointer, remove duplicate
 865    interfaces and make sure that all symbols are either functions or
 866    subroutines.  Returns nonzero if something goes wrong.  */
 867
 868 static int
 869 check_interface0 (gfc_interface * p, const char *interface_name)
 870 {
 871   gfc_interface *psave, *q, *qlast;
 872
 873   psave = p;
 874   /* Make sure all symbols in the interface have been defined as
 875      functions or subroutines.  */
 876   for (; p; p = p->next)
 877     if (!p->sym->attr.function && !p->sym->attr.subroutine)
 878       {
 879         gfc_error ("Procedure '%s' in %s at %L is neither function nor "
 880                    "subroutine", p->sym->name, interface_name,
 881                    &p->sym->declared_at);
 882         return 1;
 883       }
 884   p = psave;
 885
 886   /* Remove duplicate interfaces in this interface list.  */
 887   for (; p; p = p->next)
 888     {
 889       qlast = p;
 890
 891       for (q = p->next; q;)
 892         {
 893           if (p->sym != q->sym)
 894             {
 895               qlast = q;
 896               q = q->next;
 897
 898             }
 899           else
 900             {
 901               /* Duplicate interface */
 902               qlast->next = q->next;
 903               gfc_free (q);
 904               q = qlast->next;
 905             }
 906         }
 907     }
 908
 909   return 0;
 910 }
 911
 912
 913 /* Check lists of interfaces to make sure that no two interfaces are
 914    ambiguous.  Duplicate interfaces (from the same symbol) are OK
 915    here.  */
 916
 917 static int
 918 check_interface1 (gfc_interface * p, gfc_interface * q,
 919                   int generic_flag, const char *interface_name)
 920 {
 921
 922   for (; p; p = p->next)
 923     for (; q; q = q->next)
 924       {
 925         if (p->sym == q->sym)
 926           continue;             /* Duplicates OK here */
 927
 928         if (strcmp (p->sym->name, q->sym->name) == 0
 929             && strcmp (p->sym->module, q->sym->module) == 0)
 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
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[0] != '\0')
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 (a->expr->expr_type != EXPR_NULL
1239           && compare_pointer (f->sym, a->expr) == 0)
1240         {
1241           if (where)
1242             gfc_error ("Actual argument for '%s' must be a pointer at %L",
1243                        f->sym->name, &a->expr->where);
1244           return 0;
1245         }
1246
1247     match:
1248       if (a == actual)
1249         na = i;
1250
1251       new[i++] = a;
1252     }
1253
1254   /* Make sure missing actual arguments are optional.  */
1255   i = 0;
1256   for (f = formal; f; f = f->next, i++)
1257     {
1258       if (new[i] != NULL)
1259         continue;
1260       if (!f->sym->attr.optional)
1261         {
1262           if (where)
1263             gfc_error ("Missing actual argument for argument '%s' at %L",
1264                        f->sym->name, where);
1265           return 0;
1266         }
1267     }
1268
1269   /* The argument lists are compatible.  We now relink a new actual
1270      argument list with null arguments in the right places.  The head
1271      of the list remains the head.  */
1272   for (i = 0; i < n; i++)
1273     if (new[i] == NULL)
1274       new[i] = gfc_get_actual_arglist ();
1275
1276   if (na != 0)
1277     {
1278       temp = *new[0];
1279       *new[0] = *actual;
1280       *actual = temp;
1281
1282       a = new[0];
1283       new[0] = new[na];
1284       new[na] = a;
1285     }
1286
1287   for (i = 0; i < n - 1; i++)
1288     new[i]->next = new[i + 1];
1289
1290   new[i]->next = NULL;
1291
1292   if (*ap == NULL && n > 0)
1293     *ap = new[0];
1294
1295   /* Note the types of omitted optional arguments.  */
1296   for (a = actual, f = formal; a; a = a->next, f = f->next)
1297     if (a->expr == NULL && a->label == NULL)
1298       a->missing_arg_type = f->sym->ts.type;
1299
1300   return 1;
1301 }
1302
1303
1304 typedef struct
1305 {
1306   gfc_formal_arglist *f;
1307   gfc_actual_arglist *a;
1308 }
1309 argpair;
1310
1311 /* qsort comparison function for argument pairs, with the following
1312    order:
1313     - p->a->expr == NULL
1314     - p->a->expr->expr_type != EXPR_VARIABLE
1315     - growing p->a->expr->symbol.  */
1316
1317 static int
1318 pair_cmp (const void *p1, const void *p2)
1319 {
1320   const gfc_actual_arglist *a1, *a2;
1321
1322   /* *p1 and *p2 are elements of the to-be-sorted array.  */
1323   a1 = ((const argpair *) p1)->a;
1324   a2 = ((const argpair *) p2)->a;
1325   if (!a1->expr)
1326     {
1327       if (!a2->expr)
1328         return 0;
1329       return -1;
1330     }
1331   if (!a2->expr)
1332     return 1;
1333   if (a1->expr->expr_type != EXPR_VARIABLE)
1334     {
1335       if (a2->expr->expr_type != EXPR_VARIABLE)
1336         return 0;
1337       return -1;
1338     }
1339   if (a2->expr->expr_type != EXPR_VARIABLE)
1340     return 1;
1341   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1342 }
1343
1344
1345 /* Given two expressions from some actual arguments, test whether they
1346    refer to the same expression. The analysis is conservative.
1347    Returning FAILURE will produce no warning.  */
1348
1349 static try
1350 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1351 {
1352   const gfc_ref *r1, *r2;
1353
1354   if (!e1 || !e2
1355       || e1->expr_type != EXPR_VARIABLE
1356       || e2->expr_type != EXPR_VARIABLE
1357       || e1->symtree->n.sym != e2->symtree->n.sym)
1358     return FAILURE;
1359
1360   /* TODO: improve comparison, see expr.c:show_ref().  */
1361   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1362     {
1363       if (r1->type != r2->type)
1364         return FAILURE;
1365       switch (r1->type)
1366         {
1367         case REF_ARRAY:
1368           if (r1->u.ar.type != r2->u.ar.type)
1369             return FAILURE;
1370           /* TODO: At the moment, consider only full arrays;
1371              we could do better.  */
1372           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1373             return FAILURE;
1374           break;
1375
1376         case REF_COMPONENT:
1377           if (r1->u.c.component != r2->u.c.component)
1378             return FAILURE;
1379           break;
1380
1381         case REF_SUBSTRING:
1382           return FAILURE;
1383
1384         default:
1385           gfc_internal_error ("compare_actual_expr(): Bad component code");
1386         }
1387     }
1388   if (!r1 && !r2)
1389     return SUCCESS;
1390   return FAILURE;
1391 }
1392
1393 /* Given formal and actual argument lists that correspond to one
1394    another, check that identical actual arguments aren't not
1395    associated with some incompatible INTENTs.  */
1396
1397 static try
1398 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1399 {
1400   sym_intent f1_intent, f2_intent;
1401   gfc_formal_arglist *f1;
1402   gfc_actual_arglist *a1;
1403   size_t n, i, j;
1404   argpair *p;
1405   try t = SUCCESS;
1406
1407   n = 0;
1408   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1409     {
1410       if (f1 == NULL && a1 == NULL)
1411         break;
1412       if (f1 == NULL || a1 == NULL)
1413         gfc_internal_error ("check_some_aliasing(): List mismatch");
1414       n++;
1415     }
1416   if (n == 0)
1417     return t;
1418   p = (argpair *) alloca (n * sizeof (argpair));
1419
1420   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1421     {
1422       p[i].f = f1;
1423       p[i].a = a1;
1424     }
1425
1426   qsort (p, n, sizeof (argpair), pair_cmp);
1427
1428   for (i = 0; i < n; i++)
1429     {
1430       if (!p[i].a->expr
1431           || p[i].a->expr->expr_type != EXPR_VARIABLE
1432           || p[i].a->expr->ts.type == BT_PROCEDURE)
1433         continue;
1434       f1_intent = p[i].f->sym->attr.intent;
1435       for (j = i + 1; j < n; j++)
1436         {
1437           /* Expected order after the sort.  */
1438           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1439             gfc_internal_error ("check_some_aliasing(): corrupted data");
1440
1441           /* Are the expression the same?  */
1442           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1443             break;
1444           f2_intent = p[j].f->sym->attr.intent;
1445           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1446               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1447             {
1448               gfc_warning ("Same actual argument associated with INTENT(%s) "
1449                            "argument '%s' and INTENT(%s) argument '%s' at %L",
1450                            gfc_intent_string (f1_intent), p[i].f->sym->name,
1451                            gfc_intent_string (f2_intent), p[j].f->sym->name,
1452                            &p[i].a->expr->where);
1453               t = FAILURE;
1454             }
1455         }
1456     }
1457
1458   return t;
1459 }
1460
1461
1462 /* Given formal and actual argument lists that correspond to one
1463    another, check that they are compatible in the sense that intents
1464    are not mismatched.  */
1465
1466 static try
1467 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1468 {
1469   sym_intent a_intent, f_intent;
1470
1471   for (;; f = f->next, a = a->next)
1472     {
1473       if (f == NULL && a == NULL)
1474         break;
1475       if (f == NULL || a == NULL)
1476         gfc_internal_error ("check_intents(): List mismatch");
1477
1478       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1479         continue;
1480
1481       a_intent = a->expr->symtree->n.sym->attr.intent;
1482       f_intent = f->sym->attr.intent;
1483
1484       if (a_intent == INTENT_IN
1485           && (f_intent == INTENT_INOUT
1486               || f_intent == INTENT_OUT))
1487         {
1488
1489           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1490                      "specifies INTENT(%s)", &a->expr->where,
1491                      gfc_intent_string (f_intent));
1492           return FAILURE;
1493         }
1494
1495       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1496         {
1497           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1498             {
1499               gfc_error
1500                 ("Procedure argument at %L is local to a PURE procedure and "
1501                  "is passed to an INTENT(%s) argument", &a->expr->where,
1502                  gfc_intent_string (f_intent));
1503               return FAILURE;
1504             }
1505
1506           if (a->expr->symtree->n.sym->attr.pointer)
1507             {
1508               gfc_error
1509                 ("Procedure argument at %L is local to a PURE procedure and "
1510                  "has the POINTER attribute", &a->expr->where);
1511               return FAILURE;
1512             }
1513         }
1514     }
1515
1516   return SUCCESS;
1517 }
1518
1519
1520 /* Check how a procedure is used against its interface.  If all goes
1521    well, the actual argument list will also end up being properly
1522    sorted.  */
1523
1524 void
1525 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1526 {
1527   /* Warn about calls with an implicit interface.  */
1528   if (gfc_option.warn_implicit_interface
1529       && sym->attr.if_source == IFSRC_UNKNOWN)
1530     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1531                  sym->name, where);
1532
1533   if (sym->attr.if_source == IFSRC_UNKNOWN
1534       || !compare_actual_formal (ap, sym->formal, 0,
1535                                  sym->attr.elemental, where))
1536     return;
1537
1538   check_intents (sym->formal, *ap);
1539   if (gfc_option.warn_aliasing)
1540     check_some_aliasing (sym->formal, *ap);
1541 }
1542
1543
1544 /* Given an interface pointer and an actual argument list, search for
1545    a formal argument list that matches the actual.  If found, returns
1546    a pointer to the symbol of the correct interface.  Returns NULL if
1547    not found.  */
1548
1549 gfc_symbol *
1550 gfc_search_interface (gfc_interface * intr, int sub_flag,
1551                       gfc_actual_arglist ** ap)
1552 {
1553   int r;
1554
1555   for (; intr; intr = intr->next)
1556     {
1557       if (sub_flag && intr->sym->attr.function)
1558         continue;
1559       if (!sub_flag && intr->sym->attr.subroutine)
1560         continue;
1561
1562       r = !intr->sym->attr.elemental;
1563
1564       if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1565         {
1566           check_intents (intr->sym->formal, *ap);
1567           if (gfc_option.warn_aliasing)
1568             check_some_aliasing (intr->sym->formal, *ap);
1569           return intr->sym;
1570         }
1571     }
1572
1573   return NULL;
1574 }
1575
1576
1577 /* Do a brute force recursive search for a symbol.  */
1578
1579 static gfc_symtree *
1580 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1581 {
1582   gfc_symtree * st;
1583
1584   if (root->n.sym == sym)
1585     return root;
1586
1587   st = NULL;
1588   if (root->left)
1589     st = find_symtree0 (root->left, sym);
1590   if (root->right && ! st)
1591     st = find_symtree0 (root->right, sym);
1592   return st;
1593 }
1594
1595
1596 /* Find a symtree for a symbol.  */
1597
1598 static gfc_symtree *
1599 find_sym_in_symtree (gfc_symbol * sym)
1600 {
1601   gfc_symtree *st;
1602   gfc_namespace *ns;
1603
1604   /* First try to find it by name.  */
1605   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1606   if (st && st->n.sym == sym)
1607     return st;
1608
1609   /* if it's been renamed, resort to a brute-force search.  */
1610   /* TODO: avoid having to do this search.  If the symbol doesn't exist
1611      in the symtree for the current namespace, it should probably be added.  */
1612   for (ns = gfc_current_ns; ns; ns = ns->parent)
1613     {
1614       st = find_symtree0 (ns->sym_root, sym);
1615       if (st)
1616         return st;
1617     }
1618   gfc_internal_error ("Unable to find symbol %s", sym->name);
1619   /* Not reached */
1620 }
1621
1622
1623 /* This subroutine is called when an expression is being resolved.
1624    The expression node in question is either a user defined operator
1625    or an intrinsic operator with arguments that aren't compatible
1626    with the operator.  This subroutine builds an actual argument list
1627    corresponding to the operands, then searches for a compatible
1628    interface.  If one is found, the expression node is replaced with
1629    the appropriate function call.  */
1630
1631 try
1632 gfc_extend_expr (gfc_expr * e)
1633 {
1634   gfc_actual_arglist *actual;
1635   gfc_symbol *sym;
1636   gfc_namespace *ns;
1637   gfc_user_op *uop;
1638   gfc_intrinsic_op i;
1639
1640   sym = NULL;
1641
1642   actual = gfc_get_actual_arglist ();
1643   actual->expr = e->op1;
1644
1645   if (e->op2 != NULL)
1646     {
1647       actual->next = gfc_get_actual_arglist ();
1648       actual->next->expr = e->op2;
1649     }
1650
1651   i = fold_unary (e->operator);
1652
1653   if (i == INTRINSIC_USER)
1654     {
1655       for (ns = gfc_current_ns; ns; ns = ns->parent)
1656         {
1657           uop = gfc_find_uop (e->uop->name, ns);
1658           if (uop == NULL)
1659             continue;
1660
1661           sym = gfc_search_interface (uop->operator, 0, &actual);
1662           if (sym != NULL)
1663             break;
1664         }
1665     }
1666   else
1667     {
1668       for (ns = gfc_current_ns; ns; ns = ns->parent)
1669         {
1670           sym = gfc_search_interface (ns->operator[i], 0, &actual);
1671           if (sym != NULL)
1672             break;
1673         }
1674     }
1675
1676   if (sym == NULL)
1677     {
1678       /* Don't use gfc_free_actual_arglist() */
1679       if (actual->next != NULL)
1680         gfc_free (actual->next);
1681       gfc_free (actual);
1682
1683       return FAILURE;
1684     }
1685
1686   /* Change the expression node to a function call.  */
1687   e->expr_type = EXPR_FUNCTION;
1688   e->symtree = find_sym_in_symtree (sym);
1689   e->value.function.actual = actual;
1690
1691   if (gfc_pure (NULL) && !gfc_pure (sym))
1692     {
1693       gfc_error
1694         ("Function '%s' called in lieu of an operator at %L must be PURE",
1695          sym->name, &e->where);
1696       return FAILURE;
1697     }
1698
1699   if (gfc_resolve_expr (e) == FAILURE)
1700     return FAILURE;
1701
1702   return SUCCESS;
1703 }
1704
1705
1706 /* Tries to replace an assignment code node with a subroutine call to
1707    the subroutine associated with the assignment operator.  Return
1708    SUCCESS if the node was replaced.  On FAILURE, no error is
1709    generated.  */
1710
1711 try
1712 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1713 {
1714   gfc_actual_arglist *actual;
1715   gfc_expr *lhs, *rhs;
1716   gfc_symbol *sym;
1717
1718   lhs = c->expr;
1719   rhs = c->expr2;
1720
1721   /* Don't allow an intrinsic assignment to be replaced.  */
1722   if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1723       && (lhs->ts.type == rhs->ts.type
1724           || (gfc_numeric_ts (&lhs->ts)
1725               && gfc_numeric_ts (&rhs->ts))))
1726     return FAILURE;
1727
1728   actual = gfc_get_actual_arglist ();
1729   actual->expr = lhs;
1730
1731   actual->next = gfc_get_actual_arglist ();
1732   actual->next->expr = rhs;
1733
1734   sym = NULL;
1735
1736   for (; ns; ns = ns->parent)
1737     {
1738       sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1739       if (sym != NULL)
1740         break;
1741     }
1742
1743   if (sym == NULL)
1744     {
1745       gfc_free (actual->next);
1746       gfc_free (actual);
1747       return FAILURE;
1748     }
1749
1750   /* Replace the assignment with the call.  */
1751   c->op = EXEC_CALL;
1752   c->symtree = find_sym_in_symtree (sym);
1753   c->expr = NULL;
1754   c->expr2 = NULL;
1755   c->ext.actual = actual;
1756
1757   if (gfc_pure (NULL) && !gfc_pure (sym))
1758     {
1759       gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
1760                  "PURE", sym->name, &c->loc);
1761       return FAILURE;
1762     }
1763
1764   return SUCCESS;
1765 }
1766
1767
1768 /* Make sure that the interface just parsed is not already present in
1769    the given interface list.  Ambiguity isn't checked yet since module
1770    procedures can be present without interfaces.  */
1771
1772 static try
1773 check_new_interface (gfc_interface * base, gfc_symbol * new)
1774 {
1775   gfc_interface *ip;
1776
1777   for (ip = base; ip; ip = ip->next)
1778     {
1779       if (ip->sym == new)
1780         {
1781           gfc_error ("Entity '%s' at %C is already present in the interface",
1782                      new->name);
1783           return FAILURE;
1784         }
1785     }
1786
1787   return SUCCESS;
1788 }
1789
1790
1791 /* Add a symbol to the current interface.  */
1792
1793 try
1794 gfc_add_interface (gfc_symbol * new)
1795 {
1796   gfc_interface **head, *intr;
1797   gfc_namespace *ns;
1798   gfc_symbol *sym;
1799
1800   switch (current_interface.type)
1801     {
1802     case INTERFACE_NAMELESS:
1803       return SUCCESS;
1804
1805     case INTERFACE_INTRINSIC_OP:
1806       for (ns = current_interface.ns; ns; ns = ns->parent)
1807         if (check_new_interface (ns->operator[current_interface.op], new)
1808             == FAILURE)
1809           return FAILURE;
1810
1811       head = &current_interface.ns->operator[current_interface.op];
1812       break;
1813
1814     case INTERFACE_GENERIC:
1815       for (ns = current_interface.ns; ns; ns = ns->parent)
1816         {
1817           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1818           if (sym == NULL)
1819             continue;
1820
1821           if (check_new_interface (sym->generic, new) == FAILURE)
1822             return FAILURE;
1823         }
1824
1825       head = &current_interface.sym->generic;
1826       break;
1827
1828     case INTERFACE_USER_OP:
1829       if (check_new_interface (current_interface.uop->operator, new) ==
1830           FAILURE)
1831         return FAILURE;
1832
1833       head = &current_interface.uop->operator;
1834       break;
1835
1836     default:
1837       gfc_internal_error ("gfc_add_interface(): Bad interface type");
1838     }
1839
1840   intr = gfc_get_interface ();
1841   intr->sym = new;
1842   intr->where = gfc_current_locus;
1843
1844   intr->next = *head;
1845   *head = intr;
1846
1847   return SUCCESS;
1848 }
1849
1850
1851 /* Gets rid of a formal argument list.  We do not free symbols.
1852    Symbols are freed when a namespace is freed.  */
1853
1854 void
1855 gfc_free_formal_arglist (gfc_formal_arglist * p)
1856 {
1857   gfc_formal_arglist *q;
1858
1859   for (; p; p = q)
1860     {
1861       q = p->next;
1862       gfc_free (p);
1863     }
1864 }