gcc/fortran/interface.c

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