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