LCOV - code coverage report
Current view: top level - gcc/fortran - interface.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 2185 2371 92.2 %
Date: 2020-03-28 11:57:23 Functions: 65 71 91.5 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Deal with interfaces.
       2                 :            :    Copyright (C) 2000-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Andy Vaught
       4                 :            : 
       5                 :            : This file is part of GCC.
       6                 :            : 
       7                 :            : GCC is free software; you can redistribute it and/or modify it under
       8                 :            : the terms of the GNU General Public License as published by the Free
       9                 :            : Software Foundation; either version 3, or (at your option) any later
      10                 :            : version.
      11                 :            : 
      12                 :            : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :            : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :            : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :            : for more details.
      16                 :            : 
      17                 :            : You should have received a copy of the GNU General Public License
      18                 :            : along with GCC; see the file COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */
      20                 :            : 
      21                 :            : 
      22                 :            : /* Deal with interfaces.  An explicit interface is represented as a
      23                 :            :    singly linked list of formal argument structures attached to the
      24                 :            :    relevant symbols.  For an implicit interface, the arguments don't
      25                 :            :    point to symbols.  Explicit interfaces point to namespaces that
      26                 :            :    contain the symbols within that interface.
      27                 :            : 
      28                 :            :    Implicit interfaces are linked together in a singly linked list
      29                 :            :    along the next_if member of symbol nodes.  Since a particular
      30                 :            :    symbol can only have a single explicit interface, the symbol cannot
      31                 :            :    be part of multiple lists and a single next-member suffices.
      32                 :            : 
      33                 :            :    This is not the case for general classes, though.  An operator
      34                 :            :    definition is independent of just about all other uses and has it's
      35                 :            :    own head pointer.
      36                 :            : 
      37                 :            :    Nameless interfaces:
      38                 :            :      Nameless interfaces create symbols with explicit interfaces within
      39                 :            :      the current namespace.  They are otherwise unlinked.
      40                 :            : 
      41                 :            :    Generic interfaces:
      42                 :            :      The generic name points to a linked list of symbols.  Each symbol
      43                 :            :      has an explicit interface.  Each explicit interface has its own
      44                 :            :      namespace containing the arguments.  Module procedures are symbols in
      45                 :            :      which the interface is added later when the module procedure is parsed.
      46                 :            : 
      47                 :            :    User operators:
      48                 :            :      User-defined operators are stored in a their own set of symtrees
      49                 :            :      separate from regular symbols.  The symtrees point to gfc_user_op
      50                 :            :      structures which in turn head up a list of relevant interfaces.
      51                 :            : 
      52                 :            :    Extended intrinsics and assignment:
      53                 :            :      The head of these interface lists are stored in the containing namespace.
      54                 :            : 
      55                 :            :    Implicit interfaces:
      56                 :            :      An implicit interface is represented as a singly linked list of
      57                 :            :      formal argument list structures that don't point to any symbol
      58                 :            :      nodes -- they just contain types.
      59                 :            : 
      60                 :            : 
      61                 :            :    When a subprogram is defined, the program unit's name points to an
      62                 :            :    interface as usual, but the link to the namespace is NULL and the
      63                 :            :    formal argument list points to symbols within the same namespace as
      64                 :            :    the program unit name.  */
      65                 :            : 
      66                 :            : #include "config.h"
      67                 :            : #include "system.h"
      68                 :            : #include "coretypes.h"
      69                 :            : #include "options.h"
      70                 :            : #include "gfortran.h"
      71                 :            : #include "match.h"
      72                 :            : #include "arith.h"
      73                 :            : 
      74                 :            : /* The current_interface structure holds information about the
      75                 :            :    interface currently being parsed.  This structure is saved and
      76                 :            :    restored during recursive interfaces.  */
      77                 :            : 
      78                 :            : gfc_interface_info current_interface;
      79                 :            : 
      80                 :            : 
      81                 :            : /* Free a singly linked list of gfc_interface structures.  */
      82                 :            : 
      83                 :            : void
      84                 :   11277000 : gfc_free_interface (gfc_interface *intr)
      85                 :            : {
      86                 :   11356700 :   gfc_interface *next;
      87                 :            : 
      88                 :   11356700 :   for (; intr; intr = next)
      89                 :            :     {
      90                 :      79697 :       next = intr->next;
      91                 :      79697 :       free (intr);
      92                 :            :     }
      93                 :   11277000 : }
      94                 :            : 
      95                 :            : 
      96                 :            : /* Change the operators unary plus and minus into binary plus and
      97                 :            :    minus respectively, leaving the rest unchanged.  */
      98                 :            : 
      99                 :            : static gfc_intrinsic_op
     100                 :       2225 : fold_unary_intrinsic (gfc_intrinsic_op op)
     101                 :            : {
     102                 :          0 :   switch (op)
     103                 :            :     {
     104                 :          0 :     case INTRINSIC_UPLUS:
     105                 :          0 :       op = INTRINSIC_PLUS;
     106                 :          0 :       break;
     107                 :         13 :     case INTRINSIC_UMINUS:
     108                 :         13 :       op = INTRINSIC_MINUS;
     109                 :          0 :       break;
     110                 :            :     default:
     111                 :            :       break;
     112                 :            :     }
     113                 :            : 
     114                 :       2225 :   return op;
     115                 :            : }
     116                 :            : 
     117                 :            : 
     118                 :            : /* Return the operator depending on the DTIO moded string.  Note that
     119                 :            :    these are not operators in the normal sense and so have been placed
     120                 :            :    beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op.  */
     121                 :            : 
     122                 :            : static gfc_intrinsic_op
     123                 :        310 : dtio_op (char* mode)
     124                 :            : {
     125                 :        310 :   if (strcmp (mode, "formatted") == 0)
     126                 :            :     return INTRINSIC_FORMATTED;
     127                 :         71 :   if (strcmp (mode, "unformatted") == 0)
     128                 :         71 :     return INTRINSIC_UNFORMATTED;
     129                 :            :   return INTRINSIC_NONE;
     130                 :            : }
     131                 :            : 
     132                 :            : 
     133                 :            : /* Match a generic specification.  Depending on which type of
     134                 :            :    interface is found, the 'name' or 'op' pointers may be set.
     135                 :            :    This subroutine doesn't return MATCH_NO.  */
     136                 :            : 
     137                 :            : match
     138                 :      15680 : gfc_match_generic_spec (interface_type *type,
     139                 :            :                         char *name,
     140                 :            :                         gfc_intrinsic_op *op)
     141                 :            : {
     142                 :      15680 :   char buffer[GFC_MAX_SYMBOL_LEN + 1];
     143                 :      15680 :   match m;
     144                 :      15680 :   gfc_intrinsic_op i;
     145                 :            : 
     146                 :      15680 :   if (gfc_match (" assignment ( = )") == MATCH_YES)
     147                 :            :     {
     148                 :        390 :       *type = INTERFACE_INTRINSIC_OP;
     149                 :        390 :       *op = INTRINSIC_ASSIGN;
     150                 :        390 :       return MATCH_YES;
     151                 :            :     }
     152                 :            : 
     153                 :      15290 :   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
     154                 :            :     {                           /* Operator i/f */
     155                 :        591 :       *type = INTERFACE_INTRINSIC_OP;
     156                 :        591 :       *op = fold_unary_intrinsic (i);
     157                 :        591 :       return MATCH_YES;
     158                 :            :     }
     159                 :            : 
     160                 :      14699 :   *op = INTRINSIC_NONE;
     161                 :      14699 :   if (gfc_match (" operator ( ") == MATCH_YES)
     162                 :            :     {
     163                 :        279 :       m = gfc_match_defined_op_name (buffer, 1);
     164                 :        279 :       if (m == MATCH_NO)
     165                 :          0 :         goto syntax;
     166                 :        279 :       if (m != MATCH_YES)
     167                 :            :         return MATCH_ERROR;
     168                 :            : 
     169                 :        279 :       m = gfc_match_char (')');
     170                 :        279 :       if (m == MATCH_NO)
     171                 :          0 :         goto syntax;
     172                 :        279 :       if (m != MATCH_YES)
     173                 :            :         return MATCH_ERROR;
     174                 :            : 
     175                 :        279 :       strcpy (name, buffer);
     176                 :        279 :       *type = INTERFACE_USER_OP;
     177                 :        279 :       return MATCH_YES;
     178                 :            :     }
     179                 :            : 
     180                 :      14420 :   if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
     181                 :            :     {
     182                 :        111 :       *op = dtio_op (buffer);
     183                 :        111 :       if (*op == INTRINSIC_FORMATTED)
     184                 :            :         {
     185                 :         75 :           strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
     186                 :         75 :           *type = INTERFACE_DTIO;
     187                 :            :         }
     188                 :        111 :       if (*op == INTRINSIC_UNFORMATTED)
     189                 :            :         {
     190                 :         36 :           strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
     191                 :         36 :           *type = INTERFACE_DTIO;
     192                 :            :         }
     193                 :        111 :       if (*op != INTRINSIC_NONE)
     194                 :            :         return MATCH_YES;
     195                 :            :     }
     196                 :            : 
     197                 :      14309 :   if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
     198                 :            :     {
     199                 :        199 :       *op = dtio_op (buffer);
     200                 :        199 :       if (*op == INTRINSIC_FORMATTED)
     201                 :            :         {
     202                 :        164 :           strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
     203                 :        164 :           *type = INTERFACE_DTIO;
     204                 :            :         }
     205                 :        199 :       if (*op == INTRINSIC_UNFORMATTED)
     206                 :            :         {
     207                 :         35 :           strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
     208                 :         35 :           *type = INTERFACE_DTIO;
     209                 :            :         }
     210                 :        199 :       if (*op != INTRINSIC_NONE)
     211                 :            :         return MATCH_YES;
     212                 :            :     }
     213                 :            : 
     214                 :      14110 :   if (gfc_match_name (buffer) == MATCH_YES)
     215                 :            :     {
     216                 :      12319 :       strcpy (name, buffer);
     217                 :      12319 :       *type = INTERFACE_GENERIC;
     218                 :      12319 :       return MATCH_YES;
     219                 :            :     }
     220                 :            : 
     221                 :       1791 :   *type = INTERFACE_NAMELESS;
     222                 :       1791 :   return MATCH_YES;
     223                 :            : 
     224                 :          0 : syntax:
     225                 :          0 :   gfc_error ("Syntax error in generic specification at %C");
     226                 :          0 :   return MATCH_ERROR;
     227                 :            : }
     228                 :            : 
     229                 :            : 
     230                 :            : /* Match one of the five F95 forms of an interface statement.  The
     231                 :            :    matcher for the abstract interface follows.  */
     232                 :            : 
     233                 :            : match
     234                 :       5783 : gfc_match_interface (void)
     235                 :            : {
     236                 :       5783 :   char name[GFC_MAX_SYMBOL_LEN + 1];
     237                 :       5783 :   interface_type type;
     238                 :       5783 :   gfc_symbol *sym;
     239                 :       5783 :   gfc_intrinsic_op op;
     240                 :       5783 :   match m;
     241                 :            : 
     242                 :       5783 :   m = gfc_match_space ();
     243                 :            : 
     244                 :       5783 :   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
     245                 :            :     return MATCH_ERROR;
     246                 :            : 
     247                 :            :   /* If we're not looking at the end of the statement now, or if this
     248                 :            :      is not a nameless interface but we did not see a space, punt.  */
     249                 :       5783 :   if (gfc_match_eos () != MATCH_YES
     250                 :       5783 :       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
     251                 :            :     {
     252                 :          0 :       gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
     253                 :            :                  "at %C");
     254                 :          0 :       return MATCH_ERROR;
     255                 :            :     }
     256                 :            : 
     257                 :       5783 :   current_interface.type = type;
     258                 :            : 
     259                 :       5783 :   switch (type)
     260                 :            :     {
     261                 :       3419 :     case INTERFACE_DTIO:
     262                 :       3419 :     case INTERFACE_GENERIC:
     263                 :       3419 :       if (gfc_get_symbol (name, NULL, &sym))
     264                 :            :         return MATCH_ERROR;
     265                 :            : 
     266                 :       3419 :       if (!sym->attr.generic
     267                 :       3419 :           && !gfc_add_generic (&sym->attr, sym->name, NULL))
     268                 :            :         return MATCH_ERROR;
     269                 :            : 
     270                 :       3418 :       if (sym->attr.dummy)
     271                 :            :         {
     272                 :          0 :           gfc_error ("Dummy procedure %qs at %C cannot have a "
     273                 :            :                      "generic interface", sym->name);
     274                 :          0 :           return MATCH_ERROR;
     275                 :            :         }
     276                 :            : 
     277                 :       3418 :       current_interface.sym = gfc_new_block = sym;
     278                 :       3418 :       break;
     279                 :            : 
     280                 :        126 :     case INTERFACE_USER_OP:
     281                 :        126 :       current_interface.uop = gfc_get_uop (name);
     282                 :        126 :       break;
     283                 :            : 
     284                 :        449 :     case INTERFACE_INTRINSIC_OP:
     285                 :        449 :       current_interface.op = op;
     286                 :        449 :       break;
     287                 :            : 
     288                 :            :     case INTERFACE_NAMELESS:
     289                 :            :     case INTERFACE_ABSTRACT:
     290                 :            :       break;
     291                 :            :     }
     292                 :            : 
     293                 :            :   return MATCH_YES;
     294                 :            : }
     295                 :            : 
     296                 :            : 
     297                 :            : 
     298                 :            : /* Match a F2003 abstract interface.  */
     299                 :            : 
     300                 :            : match
     301                 :        395 : gfc_match_abstract_interface (void)
     302                 :            : {
     303                 :        395 :   match m;
     304                 :            : 
     305                 :        395 :   if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
     306                 :            :     return MATCH_ERROR;
     307                 :            : 
     308                 :        394 :   m = gfc_match_eos ();
     309                 :            : 
     310                 :        394 :   if (m != MATCH_YES)
     311                 :            :     {
     312                 :          1 :       gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
     313                 :          1 :       return MATCH_ERROR;
     314                 :            :     }
     315                 :            : 
     316                 :        393 :   current_interface.type = INTERFACE_ABSTRACT;
     317                 :            : 
     318                 :        393 :   return m;
     319                 :            : }
     320                 :            : 
     321                 :            : 
     322                 :            : /* Match the different sort of generic-specs that can be present after
     323                 :            :    the END INTERFACE itself.  */
     324                 :            : 
     325                 :            : match
     326                 :        414 : gfc_match_end_interface (void)
     327                 :            : {
     328                 :        414 :   char name[GFC_MAX_SYMBOL_LEN + 1];
     329                 :        414 :   interface_type type;
     330                 :        414 :   gfc_intrinsic_op op;
     331                 :        414 :   match m;
     332                 :            : 
     333                 :        414 :   m = gfc_match_space ();
     334                 :            : 
     335                 :        414 :   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
     336                 :            :     return MATCH_ERROR;
     337                 :            : 
     338                 :            :   /* If we're not looking at the end of the statement now, or if this
     339                 :            :      is not a nameless interface but we did not see a space, punt.  */
     340                 :        414 :   if (gfc_match_eos () != MATCH_YES
     341                 :        414 :       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
     342                 :            :     {
     343                 :          0 :       gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
     344                 :            :                  "statement at %C");
     345                 :          0 :       return MATCH_ERROR;
     346                 :            :     }
     347                 :            : 
     348                 :        414 :   m = MATCH_YES;
     349                 :            : 
     350                 :        414 :   switch (current_interface.type)
     351                 :            :     {
     352                 :          0 :     case INTERFACE_NAMELESS:
     353                 :          0 :     case INTERFACE_ABSTRACT:
     354                 :          0 :       if (type != INTERFACE_NAMELESS)
     355                 :            :         {
     356                 :          0 :           gfc_error ("Expected a nameless interface at %C");
     357                 :          0 :           m = MATCH_ERROR;
     358                 :            :         }
     359                 :            : 
     360                 :            :       break;
     361                 :            : 
     362                 :        123 :     case INTERFACE_INTRINSIC_OP:
     363                 :        123 :       if (type != current_interface.type || op != current_interface.op)
     364                 :            :         {
     365                 :            : 
     366                 :         14 :           if (current_interface.op == INTRINSIC_ASSIGN)
     367                 :            :             {
     368                 :          0 :               m = MATCH_ERROR;
     369                 :          0 :               gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
     370                 :            :             }
     371                 :            :           else
     372                 :            :             {
     373                 :         14 :               const char *s1, *s2;
     374                 :         14 :               s1 = gfc_op2string (current_interface.op);
     375                 :         14 :               s2 = gfc_op2string (op);
     376                 :            : 
     377                 :            :               /* The following if-statements are used to enforce C1202
     378                 :            :                  from F2003.  */
     379                 :         14 :               if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
     380                 :         13 :                   || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
     381                 :            :                 break;
     382                 :         12 :               if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
     383                 :         11 :                   || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
     384                 :            :                 break;
     385                 :         10 :               if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
     386                 :          9 :                   || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
     387                 :            :                 break;
     388                 :          8 :               if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
     389                 :          7 :                   || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
     390                 :            :                 break;
     391                 :          6 :               if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
     392                 :          5 :                   || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
     393                 :            :                 break;
     394                 :          4 :               if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
     395                 :          3 :                   || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
     396                 :            :                 break;
     397                 :            : 
     398                 :          2 :               m = MATCH_ERROR;
     399                 :          2 :               if (strcmp(s2, "none") == 0)
     400                 :          1 :                 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
     401                 :            :                            "at %C", s1);
     402                 :            :               else
     403                 :          1 :                 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
     404                 :            :                            "but got %qs", s1, s2);
     405                 :            :             }
     406                 :            : 
     407                 :            :         }
     408                 :            : 
     409                 :            :       break;
     410                 :            : 
     411                 :         14 :     case INTERFACE_USER_OP:
     412                 :            :       /* Comparing the symbol node names is OK because only use-associated
     413                 :            :          symbols can be renamed.  */
     414                 :         14 :       if (type != current_interface.type
     415                 :         14 :           || strcmp (current_interface.uop->name, name) != 0)
     416                 :            :         {
     417                 :          0 :           gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
     418                 :          0 :                      current_interface.uop->name);
     419                 :          0 :           m = MATCH_ERROR;
     420                 :            :         }
     421                 :            : 
     422                 :            :       break;
     423                 :            : 
     424                 :        277 :     case INTERFACE_DTIO:
     425                 :        277 :     case INTERFACE_GENERIC:
     426                 :        277 :       if (type != current_interface.type
     427                 :        277 :           || strcmp (current_interface.sym->name, name) != 0)
     428                 :            :         {
     429                 :          0 :           gfc_error ("Expecting %<END INTERFACE %s%> at %C",
     430                 :          0 :                      current_interface.sym->name);
     431                 :          0 :           m = MATCH_ERROR;
     432                 :            :         }
     433                 :            : 
     434                 :            :       break;
     435                 :            :     }
     436                 :            : 
     437                 :            :   return m;
     438                 :            : }
     439                 :            : 
     440                 :            : 
     441                 :            : /* Return whether the component was defined anonymously.  */
     442                 :            : 
     443                 :            : static bool
     444                 :       4253 : is_anonymous_component (gfc_component *cmp)
     445                 :            : {
     446                 :            :   /* Only UNION and MAP components are anonymous.  In the case of a MAP,
     447                 :            :      the derived type symbol is FL_STRUCT and the component name looks like mM*.
     448                 :            :      This is the only case in which the second character of a component name is
     449                 :            :      uppercase.  */
     450                 :       4253 :   return cmp->ts.type == BT_UNION
     451                 :       4253 :     || (cmp->ts.type == BT_DERIVED
     452                 :         82 :         && cmp->ts.u.derived->attr.flavor == FL_STRUCT
     453                 :         68 :         && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1]));
     454                 :            : }
     455                 :            : 
     456                 :            : 
     457                 :            : /* Return whether the derived type was defined anonymously.  */
     458                 :            : 
     459                 :            : static bool
     460                 :     373194 : is_anonymous_dt (gfc_symbol *derived)
     461                 :            : {
     462                 :            :   /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
     463                 :            :      types can be anonymous.  For anonymous MAP/STRUCTURE, we have FL_STRUCT
     464                 :            :      and the type name looks like XX*.  This is the only case in which the
     465                 :            :      second character of a type name is uppercase.  */
     466                 :     373194 :   return derived->attr.flavor == FL_UNION
     467                 :          0 :     || (derived->attr.flavor == FL_STRUCT
     468                 :       3294 :         && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1]));
     469                 :            : }
     470                 :            : 
     471                 :            : 
     472                 :            : /* Compare components according to 4.4.2 of the Fortran standard.  */
     473                 :            : 
     474                 :            : static bool
     475                 :       2284 : compare_components (gfc_component *cmp1, gfc_component *cmp2,
     476                 :            :     gfc_symbol *derived1, gfc_symbol *derived2)
     477                 :            : {
     478                 :            :   /* Compare names, but not for anonymous components such as UNION or MAP.  */
     479                 :       1969 :   if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
     480                 :       3968 :       && strcmp (cmp1->name, cmp2->name) != 0)
     481                 :            :     return false;
     482                 :            : 
     483                 :       1421 :   if (cmp1->attr.access != cmp2->attr.access)
     484                 :            :     return false;
     485                 :            : 
     486                 :       1421 :   if (cmp1->attr.pointer != cmp2->attr.pointer)
     487                 :            :     return false;
     488                 :            : 
     489                 :       1421 :   if (cmp1->attr.dimension != cmp2->attr.dimension)
     490                 :            :     return false;
     491                 :            : 
     492                 :       1287 :   if (cmp1->attr.allocatable != cmp2->attr.allocatable)
     493                 :            :     return false;
     494                 :            : 
     495                 :       1287 :   if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
     496                 :            :     return false;
     497                 :            : 
     498                 :       1263 :   if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
     499                 :            :     {
     500                 :         57 :       gfc_charlen *l1 = cmp1->ts.u.cl;
     501                 :         57 :       gfc_charlen *l2 = cmp2->ts.u.cl;
     502                 :         57 :       if (l1 && l2 && l1->length && l2->length
     503                 :         57 :           && l1->length->expr_type == EXPR_CONSTANT
     504                 :         57 :           && l2->length->expr_type == EXPR_CONSTANT
     505                 :        114 :           && gfc_dep_compare_expr (l1->length, l2->length) != 0)
     506                 :            :         return false;
     507                 :            :     }
     508                 :            : 
     509                 :            :   /* Make sure that link lists do not put this function into an
     510                 :            :      endless recursive loop!  */
     511                 :         23 :   if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
     512                 :       1257 :       && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
     513                 :       2515 :       && !gfc_compare_types (&cmp1->ts, &cmp2->ts))
     514                 :            :     return false;
     515                 :            : 
     516                 :        840 :   else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
     517                 :          1 :         && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
     518                 :            :     return false;
     519                 :            : 
     520                 :        840 :   else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
     521                 :        839 :         &&  (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
     522                 :          0 :     return false;
     523                 :            : 
     524                 :            :   return true;
     525                 :            : }
     526                 :            : 
     527                 :            : 
     528                 :            : /* Compare two union types by comparing the components of their maps.
     529                 :            :    Because unions and maps are anonymous their types get special internal
     530                 :            :    names; therefore the usual derived type comparison will fail on them.
     531                 :            : 
     532                 :            :    Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
     533                 :            :    gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
     534                 :            :    definitions' than 'equivalent structure'. */
     535                 :            : 
     536                 :            : static bool
     537                 :        760 : compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
     538                 :            : {
     539                 :        760 :   gfc_component *map1, *map2, *cmp1, *cmp2;
     540                 :        760 :   gfc_symbol *map1_t, *map2_t;
     541                 :            : 
     542                 :        760 :   if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION)
     543                 :            :     return false;
     544                 :            : 
     545                 :        133 :   if (un1->attr.zero_comp != un2->attr.zero_comp)
     546                 :            :     return false;
     547                 :            : 
     548                 :        133 :   if (un1->attr.zero_comp)
     549                 :            :     return true;
     550                 :            : 
     551                 :        131 :   map1 = un1->components;
     552                 :        131 :   map2 = un2->components;
     553                 :            : 
     554                 :            :   /* In terms of 'equality' here we are worried about types which are
     555                 :            :      declared the same in two places, not types that represent equivalent
     556                 :            :      structures. (This is common because of FORTRAN's weird scoping rules.)
     557                 :            :      Though two unions with their maps in different orders could be equivalent,
     558                 :            :      we will say they are not equal for the purposes of this test; therefore
     559                 :            :      we compare the maps sequentially. */
     560                 :        214 :   for (;;)
     561                 :            :     {
     562                 :        214 :       map1_t = map1->ts.u.derived;
     563                 :        214 :       map2_t = map2->ts.u.derived;
     564                 :            : 
     565                 :        214 :       cmp1 = map1_t->components;
     566                 :        214 :       cmp2 = map2_t->components;
     567                 :            : 
     568                 :            :       /* Protect against null components.  */
     569                 :        214 :       if (map1_t->attr.zero_comp != map2_t->attr.zero_comp)
     570                 :            :         return false;
     571                 :            : 
     572                 :        214 :       if (map1_t->attr.zero_comp)
     573                 :            :         return true;
     574                 :            : 
     575                 :        597 :       for (;;)
     576                 :            :         {
     577                 :            :           /* No two fields will ever point to the same map type unless they are
     578                 :            :              the same component, because one map field is created with its type
     579                 :            :              declaration. Therefore don't worry about recursion here. */
     580                 :            :           /* TODO: worry about recursion into parent types of the unions? */
     581                 :        597 :           if (!compare_components (cmp1, cmp2, map1_t, map2_t))
     582                 :            :             return false;
     583                 :            : 
     584                 :        591 :           cmp1 = cmp1->next;
     585                 :        591 :           cmp2 = cmp2->next;
     586                 :            : 
     587                 :        591 :           if (cmp1 == NULL && cmp2 == NULL)
     588                 :            :             break;
     589                 :        384 :           if (cmp1 == NULL || cmp2 == NULL)
     590                 :            :             return false;
     591                 :            :         }
     592                 :            : 
     593                 :        207 :       map1 = map1->next;
     594                 :        207 :       map2 = map2->next;
     595                 :            : 
     596                 :        207 :       if (map1 == NULL && map2 == NULL)
     597                 :            :         break;
     598                 :         83 :       if (map1 == NULL || map2 == NULL)
     599                 :            :         return false;
     600                 :            :     }
     601                 :            : 
     602                 :            :   return true;
     603                 :            : }
     604                 :            : 
     605                 :            : 
     606                 :            : 
     607                 :            : /* Compare two derived types using the criteria in 4.4.2 of the standard,
     608                 :            :    recursing through gfc_compare_types for the components.  */
     609                 :            : 
     610                 :            : bool
     611                 :     351558 : gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
     612                 :            : {
     613                 :     351558 :   gfc_component *cmp1, *cmp2;
     614                 :            : 
     615                 :     351558 :   if (derived1 == derived2)
     616                 :            :     return true;
     617                 :            : 
     618                 :     198166 :   if (!derived1 || !derived2)
     619                 :          1 :     gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
     620                 :            : 
     621                 :            :   /* Compare UNION types specially.  */
     622                 :     198165 :   if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION)
     623                 :        627 :     return compare_union_types (derived1, derived2);
     624                 :            : 
     625                 :            :   /* Special case for comparing derived types across namespaces.  If the
     626                 :            :      true names and module names are the same and the module name is
     627                 :            :      nonnull, then they are equal.  */
     628                 :     197538 :   if (strcmp (derived1->name, derived2->name) == 0
     629                 :      11340 :       && derived1->module != NULL && derived2->module != NULL
     630                 :      10604 :       && strcmp (derived1->module, derived2->module) == 0)
     631                 :            :     return true;
     632                 :            : 
     633                 :            :   /* Compare type via the rules of the standard.  Both types must have
     634                 :            :      the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
     635                 :            :      because they can be anonymous; therefore two structures with different
     636                 :            :      names may be equal.  */
     637                 :            : 
     638                 :            :   /* Compare names, but not for anonymous types such as UNION or MAP.  */
     639                 :     188244 :   if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
     640                 :     185683 :       && strcmp (derived1->name, derived2->name) != 0)
     641                 :            :     return false;
     642                 :            : 
     643                 :       2431 :   if (derived1->component_access == ACCESS_PRIVATE
     644                 :       2430 :       || derived2->component_access == ACCESS_PRIVATE)
     645                 :            :     return false;
     646                 :            : 
     647                 :       2430 :   if (!(derived1->attr.sequence && derived2->attr.sequence)
     648                 :        776 :       && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
     649                 :        773 :       && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
     650                 :            :     return false;
     651                 :            : 
     652                 :            :   /* Protect against null components.  */
     653                 :       1657 :   if (derived1->attr.zero_comp != derived2->attr.zero_comp)
     654                 :            :     return false;
     655                 :            : 
     656                 :       1657 :   if (derived1->attr.zero_comp)
     657                 :            :     return true;
     658                 :            : 
     659                 :       1657 :   cmp1 = derived1->components;
     660                 :       1657 :   cmp2 = derived2->components;
     661                 :            : 
     662                 :            :   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
     663                 :            :      simple test can speed things up.  Otherwise, lots of things have to
     664                 :            :      match.  */
     665                 :       1687 :   for (;;)
     666                 :            :     {
     667                 :       1687 :       if (!compare_components (cmp1, cmp2, derived1, derived2))
     668                 :            :         return false;
     669                 :            : 
     670                 :        249 :       cmp1 = cmp1->next;
     671                 :        249 :       cmp2 = cmp2->next;
     672                 :            : 
     673                 :        249 :       if (cmp1 == NULL && cmp2 == NULL)
     674                 :            :         break;
     675                 :         36 :       if (cmp1 == NULL || cmp2 == NULL)
     676                 :            :         return false;
     677                 :            :     }
     678                 :            : 
     679                 :            :   return true;
     680                 :            : }
     681                 :            : 
     682                 :            : 
     683                 :            : /* Compare two typespecs, recursively if necessary.  */
     684                 :            : 
     685                 :            : bool
     686                 :    3151990 : gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
     687                 :            : {
     688                 :            :   /* See if one of the typespecs is a BT_VOID, which is what is being used
     689                 :            :      to allow the funcs like c_f_pointer to accept any pointer type.
     690                 :            :      TODO: Possibly should narrow this to just the one typespec coming in
     691                 :            :      that is for the formal arg, but oh well.  */
     692                 :    3151990 :   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     693                 :            :     return true;
     694                 :            : 
     695                 :            :   /* Special case for our C interop types.  FIXME: There should be a
     696                 :            :      better way of doing this.  When ISO C binding is cleared up,
     697                 :            :      this can probably be removed.  See PR 57048.  */
     698                 :            : 
     699                 :    3151980 :   if (((ts1->type == BT_INTEGER && ts2->type == BT_DERIVED)
     700                 :    3151290 :        || (ts1->type == BT_DERIVED && ts2->type == BT_INTEGER))
     701                 :       1078 :       && ts1->u.derived && ts2->u.derived
     702                 :          1 :       && ts1->u.derived == ts2->u.derived)
     703                 :            :     return true;
     704                 :            : 
     705                 :            :   /* The _data component is not always present, therefore check for its
     706                 :            :      presence before assuming, that its derived->attr is available.
     707                 :            :      When the _data component is not present, then nevertheless the
     708                 :            :      unlimited_polymorphic flag may be set in the derived type's attr.  */
     709                 :    3151980 :   if (ts1->type == BT_CLASS && ts1->u.derived->components
     710                 :      20389 :       && ((ts1->u.derived->attr.is_class
     711                 :      20383 :            && ts1->u.derived->components->ts.u.derived->attr
     712                 :      20389 :                                                   .unlimited_polymorphic)
     713                 :      18751 :           || ts1->u.derived->attr.unlimited_polymorphic))
     714                 :            :     return true;
     715                 :            : 
     716                 :            :   /* F2003: C717  */
     717                 :    3150340 :   if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
     718                 :        656 :       && ts2->u.derived->components
     719                 :        655 :       && ((ts2->u.derived->attr.is_class
     720                 :        653 :            && ts2->u.derived->components->ts.u.derived->attr
     721                 :        655 :                                                   .unlimited_polymorphic)
     722                 :        627 :           || ts2->u.derived->attr.unlimited_polymorphic)
     723                 :         28 :       && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
     724                 :            :     return true;
     725                 :            : 
     726                 :    3150310 :   if (ts1->type != ts2->type
     727                 :     488465 :       && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
     728                 :      32270 :           || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
     729                 :            :     return false;
     730                 :            : 
     731                 :    2667280 :   if (ts1->type == BT_UNION)
     732                 :        133 :     return compare_union_types (ts1->u.derived, ts2->u.derived);
     733                 :            : 
     734                 :    2667150 :   if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
     735                 :    2535690 :     return (ts1->kind == ts2->kind);
     736                 :            : 
     737                 :            :   /* Compare derived types.  */
     738                 :     131461 :   return gfc_type_compatible (ts1, ts2);
     739                 :            : }
     740                 :            : 
     741                 :            : 
     742                 :            : static bool
     743                 :    2065750 : compare_type (gfc_symbol *s1, gfc_symbol *s2)
     744                 :            : {
     745                 :    2065750 :   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
     746                 :            :     return true;
     747                 :            : 
     748                 :    1957100 :   return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
     749                 :            : }
     750                 :            : 
     751                 :            : 
     752                 :            : static bool
     753                 :      73639 : compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2)
     754                 :            : {
     755                 :            :   /* TYPE and CLASS of the same declared type are type compatible,
     756                 :            :      but have different characteristics.  */
     757                 :      73639 :   if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
     758                 :      73631 :       || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
     759                 :            :     return false;
     760                 :            : 
     761                 :      73630 :   return compare_type (s1, s2);
     762                 :            : }
     763                 :            : 
     764                 :            : 
     765                 :            : static bool
     766                 :     353426 : compare_rank (gfc_symbol *s1, gfc_symbol *s2)
     767                 :            : {
     768                 :     353426 :   gfc_array_spec *as1, *as2;
     769                 :     353426 :   int r1, r2;
     770                 :            : 
     771                 :     353426 :   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
     772                 :            :     return true;
     773                 :            : 
     774                 :     489540 :   as1 = (s1->ts.type == BT_CLASS
     775                 :       3927 :          && !s1->ts.u.derived->attr.unlimited_polymorphic)
     776                 :     248697 :         ? CLASS_DATA (s1)->as : s1->as;
     777                 :     489540 :   as2 = (s2->ts.type == BT_CLASS
     778                 :       3909 :          && !s2->ts.u.derived->attr.unlimited_polymorphic)
     779                 :     248679 :         ? CLASS_DATA (s2)->as : s2->as;
     780                 :            : 
     781                 :     244770 :   r1 = as1 ? as1->rank : 0;
     782                 :     244770 :   r2 = as2 ? as2->rank : 0;
     783                 :            : 
     784                 :     244770 :   if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
     785                 :       2295 :     return false;  /* Ranks differ.  */
     786                 :            : 
     787                 :            :   return true;
     788                 :            : }
     789                 :            : 
     790                 :            : 
     791                 :            : /* Given two symbols that are formal arguments, compare their ranks
     792                 :            :    and types.  Returns true if they have the same rank and type,
     793                 :            :    false otherwise.  */
     794                 :            : 
     795                 :            : static bool
     796                 :    1990020 : compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
     797                 :            : {
     798                 :    1990020 :   return compare_type (s1, s2) && compare_rank (s1, s2);
     799                 :            : }
     800                 :            : 
     801                 :            : 
     802                 :            : /* Given two symbols that are formal arguments, compare their types
     803                 :            :    and rank and their formal interfaces if they are both dummy
     804                 :            :    procedures.  Returns true if the same, false if different.  */
     805                 :            : 
     806                 :            : static bool
     807                 :    1931220 : compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
     808                 :            : {
     809                 :    1931220 :   if (s1 == NULL || s2 == NULL)
     810                 :        106 :     return (s1 == s2);
     811                 :            : 
     812                 :    1931110 :   if (s1 == s2)
     813                 :            :     return true;
     814                 :            : 
     815                 :    1931110 :   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
     816                 :    1931040 :     return compare_type_rank (s1, s2);
     817                 :            : 
     818                 :         74 :   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
     819                 :            :     return false;
     820                 :            : 
     821                 :            :   /* At this point, both symbols are procedures.  It can happen that
     822                 :            :      external procedures are compared, where one is identified by usage
     823                 :            :      to be a function or subroutine but the other is not.  Check TKR
     824                 :            :      nonetheless for these cases.  */
     825                 :          6 :   if (s1->attr.function == 0 && s1->attr.subroutine == 0)
     826                 :          2 :     return s1->attr.external ? compare_type_rank (s1, s2) : false;
     827                 :            : 
     828                 :          4 :   if (s2->attr.function == 0 && s2->attr.subroutine == 0)
     829                 :          0 :     return s2->attr.external ? compare_type_rank (s1, s2) : false;
     830                 :            : 
     831                 :            :   /* Now the type of procedure has been identified.  */
     832                 :          4 :   if (s1->attr.function != s2->attr.function
     833                 :          4 :       || s1->attr.subroutine != s2->attr.subroutine)
     834                 :            :     return false;
     835                 :            : 
     836                 :          4 :   if (s1->attr.function && !compare_type_rank (s1, s2))
     837                 :          0 :     return false;
     838                 :            : 
     839                 :            :   /* Originally, gfortran recursed here to check the interfaces of passed
     840                 :            :      procedures.  This is explicitly not required by the standard.  */
     841                 :            :   return true;
     842                 :            : }
     843                 :            : 
     844                 :            : 
     845                 :            : /* Given a formal argument list and a keyword name, search the list
     846                 :            :    for that keyword.  Returns the correct symbol node if found, NULL
     847                 :            :    if not found.  */
     848                 :            : 
     849                 :            : static gfc_symbol *
     850                 :          0 : find_keyword_arg (const char *name, gfc_formal_arglist *f)
     851                 :            : {
     852                 :      25430 :   for (; f; f = f->next)
     853                 :      25430 :     if (strcmp (f->sym->name, name) == 0)
     854                 :          0 :       return f->sym;
     855                 :            : 
     856                 :            :   return NULL;
     857                 :            : }
     858                 :            : 
     859                 :            : 
     860                 :            : /******** Interface checking subroutines **********/
     861                 :            : 
     862                 :            : 
     863                 :            : /* Given an operator interface and the operator, make sure that all
     864                 :            :    interfaces for that operator are legal.  */
     865                 :            : 
     866                 :            : bool
     867                 :       2418 : gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
     868                 :            :                               locus opwhere)
     869                 :            : {
     870                 :       2418 :   gfc_formal_arglist *formal;
     871                 :       2418 :   sym_intent i1, i2;
     872                 :       2418 :   bt t1, t2;
     873                 :       2418 :   int args, r1, r2, k1, k2;
     874                 :            : 
     875                 :       2418 :   gcc_assert (sym);
     876                 :            : 
     877                 :       2418 :   args = 0;
     878                 :       2418 :   t1 = t2 = BT_UNKNOWN;
     879                 :       2418 :   i1 = i2 = INTENT_UNKNOWN;
     880                 :       2418 :   r1 = r2 = -1;
     881                 :       2418 :   k1 = k2 = -1;
     882                 :            : 
     883                 :       7235 :   for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
     884                 :            :     {
     885                 :       4818 :       gfc_symbol *fsym = formal->sym;
     886                 :       4818 :       if (fsym == NULL)
     887                 :            :         {
     888                 :          1 :           gfc_error ("Alternate return cannot appear in operator "
     889                 :            :                      "interface at %L", &sym->declared_at);
     890                 :          1 :           return false;
     891                 :            :         }
     892                 :       4817 :       if (args == 0)
     893                 :            :         {
     894                 :       2418 :           t1 = fsym->ts.type;
     895                 :       2418 :           i1 = fsym->attr.intent;
     896                 :       2418 :           r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
     897                 :       2418 :           k1 = fsym->ts.kind;
     898                 :            :         }
     899                 :       4817 :       if (args == 1)
     900                 :            :         {
     901                 :       2399 :           t2 = fsym->ts.type;
     902                 :       2399 :           i2 = fsym->attr.intent;
     903                 :       2399 :           r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
     904                 :       2399 :           k2 = fsym->ts.kind;
     905                 :            :         }
     906                 :       4817 :       args++;
     907                 :            :     }
     908                 :            : 
     909                 :            :   /* Only +, - and .not. can be unary operators.
     910                 :            :      .not. cannot be a binary operator.  */
     911                 :       2417 :   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
     912                 :         17 :                                 && op != INTRINSIC_MINUS
     913                 :         17 :                                 && op != INTRINSIC_NOT)
     914                 :       2416 :       || (args == 2 && op == INTRINSIC_NOT))
     915                 :            :     {
     916                 :          1 :       if (op == INTRINSIC_ASSIGN)
     917                 :          0 :         gfc_error ("Assignment operator interface at %L must have "
     918                 :            :                    "two arguments", &sym->declared_at);
     919                 :            :       else
     920                 :          1 :         gfc_error ("Operator interface at %L has the wrong number of arguments",
     921                 :            :                    &sym->declared_at);
     922                 :          1 :       return false;
     923                 :            :     }
     924                 :            : 
     925                 :            :   /* Check that intrinsics are mapped to functions, except
     926                 :            :      INTRINSIC_ASSIGN which should map to a subroutine.  */
     927                 :       2416 :   if (op == INTRINSIC_ASSIGN)
     928                 :            :     {
     929                 :        929 :       gfc_formal_arglist *dummy_args;
     930                 :            : 
     931                 :        929 :       if (!sym->attr.subroutine)
     932                 :            :         {
     933                 :          1 :           gfc_error ("Assignment operator interface at %L must be "
     934                 :            :                      "a SUBROUTINE", &sym->declared_at);
     935                 :          1 :           return false;
     936                 :            :         }
     937                 :            : 
     938                 :            :       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
     939                 :            :          - First argument an array with different rank than second,
     940                 :            :          - First argument is a scalar and second an array,
     941                 :            :          - Types and kinds do not conform, or
     942                 :            :          - First argument is of derived type.  */
     943                 :        928 :       dummy_args = gfc_sym_get_dummy_args (sym);
     944                 :        928 :       if (dummy_args->sym->ts.type != BT_DERIVED
     945                 :        928 :           && dummy_args->sym->ts.type != BT_CLASS
     946                 :        104 :           && (r2 == 0 || r1 == r2)
     947                 :       1029 :           && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
     948                 :         96 :               || (gfc_numeric_ts (&dummy_args->sym->ts)
     949                 :         62 :                   && gfc_numeric_ts (&dummy_args->next->sym->ts))))
     950                 :            :         {
     951                 :          5 :           gfc_error ("Assignment operator interface at %L must not redefine "
     952                 :            :                      "an INTRINSIC type assignment", &sym->declared_at);
     953                 :          5 :           return false;
     954                 :            :         }
     955                 :            :     }
     956                 :            :   else
     957                 :            :     {
     958                 :       1487 :       if (!sym->attr.function)
     959                 :            :         {
     960                 :          1 :           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
     961                 :            :                      &sym->declared_at);
     962                 :          1 :           return false;
     963                 :            :         }
     964                 :            :     }
     965                 :            : 
     966                 :            :   /* Check intents on operator interfaces.  */
     967                 :       2409 :   if (op == INTRINSIC_ASSIGN)
     968                 :            :     {
     969                 :        923 :       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
     970                 :            :         {
     971                 :          0 :           gfc_error ("First argument of defined assignment at %L must be "
     972                 :            :                      "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
     973                 :          0 :           return false;
     974                 :            :         }
     975                 :            : 
     976                 :        923 :       if (i2 != INTENT_IN)
     977                 :            :         {
     978                 :          0 :           gfc_error ("Second argument of defined assignment at %L must be "
     979                 :            :                      "INTENT(IN)", &sym->declared_at);
     980                 :          0 :           return false;
     981                 :            :         }
     982                 :            :     }
     983                 :            :   else
     984                 :            :     {
     985                 :       1486 :       if (i1 != INTENT_IN)
     986                 :            :         {
     987                 :          0 :           gfc_error ("First argument of operator interface at %L must be "
     988                 :            :                      "INTENT(IN)", &sym->declared_at);
     989                 :          0 :           return false;
     990                 :            :         }
     991                 :            : 
     992                 :       1486 :       if (args == 2 && i2 != INTENT_IN)
     993                 :            :         {
     994                 :          0 :           gfc_error ("Second argument of operator interface at %L must be "
     995                 :            :                      "INTENT(IN)", &sym->declared_at);
     996                 :          0 :           return false;
     997                 :            :         }
     998                 :            :     }
     999                 :            : 
    1000                 :            :   /* From now on, all we have to do is check that the operator definition
    1001                 :            :      doesn't conflict with an intrinsic operator. The rules for this
    1002                 :            :      game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
    1003                 :            :      as well as 12.3.2.1.1 of Fortran 2003:
    1004                 :            : 
    1005                 :            :      "If the operator is an intrinsic-operator (R310), the number of
    1006                 :            :      function arguments shall be consistent with the intrinsic uses of
    1007                 :            :      that operator, and the types, kind type parameters, or ranks of the
    1008                 :            :      dummy arguments shall differ from those required for the intrinsic
    1009                 :            :      operation (7.1.2)."  */
    1010                 :            : 
    1011                 :            : #define IS_NUMERIC_TYPE(t) \
    1012                 :            :   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
    1013                 :            : 
    1014                 :            :   /* Unary ops are easy, do them first.  */
    1015                 :       2409 :   if (op == INTRINSIC_NOT)
    1016                 :            :     {
    1017                 :          0 :       if (t1 == BT_LOGICAL)
    1018                 :          0 :         goto bad_repl;
    1019                 :            :       else
    1020                 :            :         return true;
    1021                 :            :     }
    1022                 :            : 
    1023                 :       2409 :   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
    1024                 :            :     {
    1025                 :         17 :       if (IS_NUMERIC_TYPE (t1))
    1026                 :          0 :         goto bad_repl;
    1027                 :            :       else
    1028                 :            :         return true;
    1029                 :            :     }
    1030                 :            : 
    1031                 :            :   /* Character intrinsic operators have same character kind, thus
    1032                 :            :      operator definitions with operands of different character kinds
    1033                 :            :      are always safe.  */
    1034                 :       2392 :   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
    1035                 :            :     return true;
    1036                 :            : 
    1037                 :            :   /* Intrinsic operators always perform on arguments of same rank,
    1038                 :            :      so different ranks is also always safe.  (rank == 0) is an exception
    1039                 :            :      to that, because all intrinsic operators are elemental.  */
    1040                 :       2392 :   if (r1 != r2 && r1 != 0 && r2 != 0)
    1041                 :            :     return true;
    1042                 :            : 
    1043                 :       2376 :   switch (op)
    1044                 :            :   {
    1045                 :        492 :     case INTRINSIC_EQ:
    1046                 :        492 :     case INTRINSIC_EQ_OS:
    1047                 :        492 :     case INTRINSIC_NE:
    1048                 :        492 :     case INTRINSIC_NE_OS:
    1049                 :        492 :       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
    1050                 :          0 :         goto bad_repl;
    1051                 :            :       /* Fall through.  */
    1052                 :            : 
    1053                 :       1126 :     case INTRINSIC_PLUS:
    1054                 :       1126 :     case INTRINSIC_MINUS:
    1055                 :       1126 :     case INTRINSIC_TIMES:
    1056                 :       1126 :     case INTRINSIC_DIVIDE:
    1057                 :       1126 :     case INTRINSIC_POWER:
    1058                 :       1126 :       if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
    1059                 :          1 :         goto bad_repl;
    1060                 :            :       break;
    1061                 :            : 
    1062                 :        238 :     case INTRINSIC_GT:
    1063                 :        238 :     case INTRINSIC_GT_OS:
    1064                 :        238 :     case INTRINSIC_GE:
    1065                 :        238 :     case INTRINSIC_GE_OS:
    1066                 :        238 :     case INTRINSIC_LT:
    1067                 :        238 :     case INTRINSIC_LT_OS:
    1068                 :        238 :     case INTRINSIC_LE:
    1069                 :        238 :     case INTRINSIC_LE_OS:
    1070                 :        238 :       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
    1071                 :          1 :         goto bad_repl;
    1072                 :        237 :       if ((t1 == BT_INTEGER || t1 == BT_REAL)
    1073                 :          0 :           && (t2 == BT_INTEGER || t2 == BT_REAL))
    1074                 :          0 :         goto bad_repl;
    1075                 :            :       break;
    1076                 :            : 
    1077                 :         36 :     case INTRINSIC_CONCAT:
    1078                 :         36 :       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
    1079                 :          0 :         goto bad_repl;
    1080                 :            :       break;
    1081                 :            : 
    1082                 :         56 :     case INTRINSIC_AND:
    1083                 :         56 :     case INTRINSIC_OR:
    1084                 :         56 :     case INTRINSIC_EQV:
    1085                 :         56 :     case INTRINSIC_NEQV:
    1086                 :         56 :       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
    1087                 :          0 :         goto bad_repl;
    1088                 :            :       break;
    1089                 :            : 
    1090                 :            :     default:
    1091                 :            :       break;
    1092                 :            :   }
    1093                 :            : 
    1094                 :            :   return true;
    1095                 :            : 
    1096                 :            : #undef IS_NUMERIC_TYPE
    1097                 :            : 
    1098                 :          2 : bad_repl:
    1099                 :          2 :   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
    1100                 :            :              &opwhere);
    1101                 :          2 :   return false;
    1102                 :            : }
    1103                 :            : 
    1104                 :            : 
    1105                 :            : /* Given a pair of formal argument lists, we see if the two lists can
    1106                 :            :    be distinguished by counting the number of nonoptional arguments of
    1107                 :            :    a given type/rank in f1 and seeing if there are less then that
    1108                 :            :    number of those arguments in f2 (including optional arguments).
    1109                 :            :    Since this test is asymmetric, it has to be called twice to make it
    1110                 :            :    symmetric. Returns nonzero if the argument lists are incompatible
    1111                 :            :    by this test. This subroutine implements rule 1 of section F03:16.2.3.
    1112                 :            :    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
    1113                 :            : 
    1114                 :            : static bool
    1115                 :     354932 : count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
    1116                 :            :                   const char *p1, const char *p2)
    1117                 :            : {
    1118                 :     354932 :   int ac1, ac2, i, j, k, n1;
    1119                 :     354932 :   gfc_formal_arglist *f;
    1120                 :            : 
    1121                 :     354932 :   typedef struct
    1122                 :            :   {
    1123                 :            :     int flag;
    1124                 :            :     gfc_symbol *sym;
    1125                 :            :   }
    1126                 :            :   arginfo;
    1127                 :            : 
    1128                 :     354932 :   arginfo *arg;
    1129                 :            : 
    1130                 :     354932 :   n1 = 0;
    1131                 :            : 
    1132                 :     998866 :   for (f = f1; f; f = f->next)
    1133                 :     643934 :     n1++;
    1134                 :            : 
    1135                 :            :   /* Build an array of integers that gives the same integer to
    1136                 :            :      arguments of the same type/rank.  */
    1137                 :     354932 :   arg = XCNEWVEC (arginfo, n1);
    1138                 :            : 
    1139                 :     354932 :   f = f1;
    1140                 :     998866 :   for (i = 0; i < n1; i++, f = f->next)
    1141                 :            :     {
    1142                 :     643934 :       arg[i].flag = -1;
    1143                 :     643934 :       arg[i].sym = f->sym;
    1144                 :            :     }
    1145                 :            : 
    1146                 :            :   k = 0;
    1147                 :            : 
    1148                 :     998866 :   for (i = 0; i < n1; i++)
    1149                 :            :     {
    1150                 :     643934 :       if (arg[i].flag != -1)
    1151                 :      90774 :         continue;
    1152                 :            : 
    1153                 :     553160 :       if (arg[i].sym && (arg[i].sym->attr.optional
    1154                 :     553123 :                          || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
    1155                 :        262 :         continue;               /* Skip OPTIONAL and PASS arguments.  */
    1156                 :            : 
    1157                 :     552898 :       arg[i].flag = k;
    1158                 :            : 
    1159                 :            :       /* Find other non-optional, non-pass arguments of the same type/rank.  */
    1160                 :     848911 :       for (j = i + 1; j < n1; j++)
    1161                 :     296013 :         if ((arg[j].sym == NULL
    1162                 :     295921 :              || !(arg[j].sym->attr.optional
    1163                 :     296135 :                   || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
    1164                 :     591866 :             && (compare_type_rank_if (arg[i].sym, arg[j].sym)
    1165                 :     253493 :                 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
    1166                 :      90774 :           arg[j].flag = k;
    1167                 :            : 
    1168                 :     552898 :       k++;
    1169                 :            :     }
    1170                 :            : 
    1171                 :            :   /* Now loop over each distinct type found in f1.  */
    1172                 :            :   k = 0;
    1173                 :     502933 :   bool rc = false;
    1174                 :            : 
    1175                 :     502933 :   for (i = 0; i < n1; i++)
    1176                 :            :     {
    1177                 :     452285 :       if (arg[i].flag != k)
    1178                 :      25741 :         continue;
    1179                 :            : 
    1180                 :     426544 :       ac1 = 1;
    1181                 :     722356 :       for (j = i + 1; j < n1; j++)
    1182                 :     295812 :         if (arg[j].flag == k)
    1183                 :      90741 :           ac1++;
    1184                 :            : 
    1185                 :            :       /* Count the number of non-pass arguments in f2 with that type,
    1186                 :            :          including those that are optional.  */
    1187                 :            :       ac2 = 0;
    1188                 :            : 
    1189                 :    1200520 :       for (f = f2; f; f = f->next)
    1190                 :        426 :         if ((!p2 || strcmp (f->sym->name, p2) != 0)
    1191                 :     774202 :             && (compare_type_rank_if (arg[i].sym, f->sym)
    1192                 :     608068 :                 || compare_type_rank_if (f->sym, arg[i].sym)))
    1193                 :     205420 :           ac2++;
    1194                 :            : 
    1195                 :     426544 :       if (ac1 > ac2)
    1196                 :            :         {
    1197                 :            :           rc = true;
    1198                 :            :           break;
    1199                 :            :         }
    1200                 :            : 
    1201                 :     122260 :       k++;
    1202                 :            :     }
    1203                 :            : 
    1204                 :     354932 :   free (arg);
    1205                 :            : 
    1206                 :     354932 :   return rc;
    1207                 :            : }
    1208                 :            : 
    1209                 :            : 
    1210                 :            : /* Returns true if two dummy arguments are distinguishable due to their POINTER
    1211                 :            :    and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
    1212                 :            :    The function is asymmetric wrt to the arguments s1 and s2 and should always
    1213                 :            :    be called twice (with flipped arguments in the second call).  */
    1214                 :            : 
    1215                 :            : static bool
    1216                 :      17901 : compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2)
    1217                 :            : {
    1218                 :            :   /* Is s1 allocatable?  */
    1219                 :          0 :   const bool a1 = s1->ts.type == BT_CLASS ?
    1220                 :      17901 :                   CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable;
    1221                 :            :   /* Is s2 a pointer?  */
    1222                 :      17901 :   const bool p2 = s2->ts.type == BT_CLASS ?
    1223                 :      17901 :                   CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer;
    1224                 :      17901 :   return a1 && p2 && (s2->attr.intent != INTENT_IN);
    1225                 :            : }
    1226                 :            : 
    1227                 :            : 
    1228                 :            : /* Perform the correspondence test in rule (3) of F08:C1215.
    1229                 :            :    Returns zero if no argument is found that satisfies this rule,
    1230                 :            :    nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
    1231                 :            :    (if applicable).
    1232                 :            : 
    1233                 :            :    This test is also not symmetric in f1 and f2 and must be called
    1234                 :            :    twice.  This test finds problems caused by sorting the actual
    1235                 :            :    argument list with keywords.  For example:
    1236                 :            : 
    1237                 :            :    INTERFACE FOO
    1238                 :            :      SUBROUTINE F1(A, B)
    1239                 :            :        INTEGER :: A ; REAL :: B
    1240                 :            :      END SUBROUTINE F1
    1241                 :            : 
    1242                 :            :      SUBROUTINE F2(B, A)
    1243                 :            :        INTEGER :: A ; REAL :: B
    1244                 :            :      END SUBROUTINE F1
    1245                 :            :    END INTERFACE FOO
    1246                 :            : 
    1247                 :            :    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
    1248                 :            : 
    1249                 :            : static bool
    1250                 :      16796 : generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
    1251                 :            :                         const char *p1, const char *p2)
    1252                 :            : {
    1253                 :      16796 :   gfc_formal_arglist *f2_save, *g;
    1254                 :      16796 :   gfc_symbol *sym;
    1255                 :            : 
    1256                 :      16796 :   f2_save = f2;
    1257                 :            : 
    1258                 :      25530 :   while (f1)
    1259                 :            :     {
    1260                 :      25488 :       if (f1->sym->attr.optional)
    1261                 :          2 :         goto next;
    1262                 :            : 
    1263                 :      25486 :       if (p1 && strcmp (f1->sym->name, p1) == 0)
    1264                 :          7 :         f1 = f1->next;
    1265                 :      25486 :       if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
    1266                 :          5 :         f2 = f2->next;
    1267                 :            : 
    1268                 :      25482 :       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
    1269                 :      16743 :                          || compare_type_rank (f2->sym, f1->sym))
    1270                 :      34228 :           && !((gfc_option.allow_std & GFC_STD_F2008)
    1271                 :       8740 :                && (compare_ptr_alloc(f1->sym, f2->sym)
    1272                 :       8733 :                    || compare_ptr_alloc(f2->sym, f1->sym))))
    1273                 :       8728 :         goto next;
    1274                 :            : 
    1275                 :            :       /* Now search for a disambiguating keyword argument starting at
    1276                 :            :          the current non-match.  */
    1277                 :      16758 :       for (g = f1; g; g = g->next)
    1278                 :            :         {
    1279                 :      16754 :           if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
    1280                 :          0 :             continue;
    1281                 :            : 
    1282                 :      16754 :           sym = find_keyword_arg (g->sym->name, f2_save);
    1283                 :      16754 :           if (sym == NULL || !compare_type_rank (g->sym, sym)
    1284                 :      16768 :               || ((gfc_option.allow_std & GFC_STD_F2008)
    1285                 :         14 :                   && (compare_ptr_alloc(sym, g->sym)
    1286                 :          7 :                       || compare_ptr_alloc(g->sym, sym))))
    1287                 :      16754 :             return true;
    1288                 :            :         }
    1289                 :            : 
    1290                 :          4 :     next:
    1291                 :       8734 :       if (f1 != NULL)
    1292                 :       8730 :         f1 = f1->next;
    1293                 :       8734 :       if (f2 != NULL)
    1294                 :       8730 :         f2 = f2->next;
    1295                 :            :     }
    1296                 :            : 
    1297                 :            :   return false;
    1298                 :            : }
    1299                 :            : 
    1300                 :            : 
    1301                 :            : static int
    1302                 :     294382 : symbol_rank (gfc_symbol *sym)
    1303                 :            : {
    1304                 :     294382 :   gfc_array_spec *as = NULL;
    1305                 :            : 
    1306                 :      16522 :   if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
    1307                 :      10068 :     as = CLASS_DATA (sym)->as;
    1308                 :            :   else
    1309                 :     284314 :     as = sym->as;
    1310                 :            : 
    1311                 :     294382 :   return as ? as->rank : 0;
    1312                 :            : }
    1313                 :            : 
    1314                 :            : 
    1315                 :            : /* Check if the characteristics of two dummy arguments match,
    1316                 :            :    cf. F08:12.3.2.  */
    1317                 :            : 
    1318                 :            : bool
    1319                 :      28686 : gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
    1320                 :            :                                  bool type_must_agree, char *errmsg,
    1321                 :            :                                  int err_len)
    1322                 :            : {
    1323                 :      28686 :   if (s1 == NULL || s2 == NULL)
    1324                 :         15 :     return s1 == s2 ? true : false;
    1325                 :            : 
    1326                 :            :   /* Check type and rank.  */
    1327                 :      28671 :   if (type_must_agree)
    1328                 :            :     {
    1329                 :      27615 :       if (!compare_type_characteristics (s1, s2)
    1330                 :      27615 :           || !compare_type_characteristics (s2, s1))
    1331                 :            :         {
    1332                 :         23 :           snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
    1333                 :            :                     s1->name, gfc_dummy_typename (&s1->ts),
    1334                 :            :                     gfc_dummy_typename (&s2->ts));
    1335                 :         23 :           return false;
    1336                 :            :         }
    1337                 :      27592 :       if (!compare_rank (s1, s2))
    1338                 :            :         {
    1339                 :          4 :           snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
    1340                 :            :                     s1->name, symbol_rank (s1), symbol_rank (s2));
    1341                 :          2 :           return false;
    1342                 :            :         }
    1343                 :            :     }
    1344                 :            : 
    1345                 :            :   /* Check INTENT.  */
    1346                 :      28646 :   if (s1->attr.intent != s2->attr.intent)
    1347                 :            :     {
    1348                 :          4 :       snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
    1349                 :            :                 s1->name);
    1350                 :          4 :       return false;
    1351                 :            :     }
    1352                 :            : 
    1353                 :            :   /* Check OPTIONAL attribute.  */
    1354                 :      28642 :   if (s1->attr.optional != s2->attr.optional)
    1355                 :            :     {
    1356                 :          1 :       snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
    1357                 :            :                 s1->name);
    1358                 :          1 :       return false;
    1359                 :            :     }
    1360                 :            : 
    1361                 :            :   /* Check ALLOCATABLE attribute.  */
    1362                 :      28641 :   if (s1->attr.allocatable != s2->attr.allocatable)
    1363                 :            :     {
    1364                 :          0 :       snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
    1365                 :            :                 s1->name);
    1366                 :          0 :       return false;
    1367                 :            :     }
    1368                 :            : 
    1369                 :            :   /* Check POINTER attribute.  */
    1370                 :      28641 :   if (s1->attr.pointer != s2->attr.pointer)
    1371                 :            :     {
    1372                 :          0 :       snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
    1373                 :            :                 s1->name);
    1374                 :          0 :       return false;
    1375                 :            :     }
    1376                 :            : 
    1377                 :            :   /* Check TARGET attribute.  */
    1378                 :      28641 :   if (s1->attr.target != s2->attr.target)
    1379                 :            :     {
    1380                 :          0 :       snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
    1381                 :            :                 s1->name);
    1382                 :          0 :       return false;
    1383                 :            :     }
    1384                 :            : 
    1385                 :            :   /* Check ASYNCHRONOUS attribute.  */
    1386                 :      28641 :   if (s1->attr.asynchronous != s2->attr.asynchronous)
    1387                 :            :     {
    1388                 :          1 :       snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
    1389                 :            :                 s1->name);
    1390                 :          1 :       return false;
    1391                 :            :     }
    1392                 :            : 
    1393                 :            :   /* Check CONTIGUOUS attribute.  */
    1394                 :      28640 :   if (s1->attr.contiguous != s2->attr.contiguous)
    1395                 :            :     {
    1396                 :          1 :       snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
    1397                 :            :                 s1->name);
    1398                 :          1 :       return false;
    1399                 :            :     }
    1400                 :            : 
    1401                 :            :   /* Check VALUE attribute.  */
    1402                 :      28639 :   if (s1->attr.value != s2->attr.value)
    1403                 :            :     {
    1404                 :          1 :       snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
    1405                 :            :                 s1->name);
    1406                 :          1 :       return false;
    1407                 :            :     }
    1408                 :            : 
    1409                 :            :   /* Check VOLATILE attribute.  */
    1410                 :      28638 :   if (s1->attr.volatile_ != s2->attr.volatile_)
    1411                 :            :     {
    1412                 :          1 :       snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
    1413                 :            :                 s1->name);
    1414                 :          1 :       return false;
    1415                 :            :     }
    1416                 :            : 
    1417                 :            :   /* Check interface of dummy procedures.  */
    1418                 :      28637 :   if (s1->attr.flavor == FL_PROCEDURE)
    1419                 :            :     {
    1420                 :         84 :       char err[200];
    1421                 :         84 :       if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
    1422                 :            :                                    NULL, NULL))
    1423                 :            :         {
    1424                 :          1 :           snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
    1425                 :            :                     "'%s': %s", s1->name, err);
    1426                 :          1 :           return false;
    1427                 :            :         }
    1428                 :            :     }
    1429                 :            : 
    1430                 :            :   /* Check string length.  */
    1431                 :      28636 :   if (s1->ts.type == BT_CHARACTER
    1432                 :       1040 :       && s1->ts.u.cl && s1->ts.u.cl->length
    1433                 :        140 :       && s2->ts.u.cl && s2->ts.u.cl->length)
    1434                 :            :     {
    1435                 :        140 :       int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
    1436                 :            :                                           s2->ts.u.cl->length);
    1437                 :        140 :       switch (compval)
    1438                 :            :       {
    1439                 :          0 :         case -1:
    1440                 :          0 :         case  1:
    1441                 :          0 :         case -3:
    1442                 :          0 :           snprintf (errmsg, err_len, "Character length mismatch "
    1443                 :            :                     "in argument '%s'", s1->name);
    1444                 :          0 :           return false;
    1445                 :            : 
    1446                 :            :         case -2:
    1447                 :            :           /* FIXME: Implement a warning for this case.
    1448                 :            :           gfc_warning (0, "Possible character length mismatch in argument %qs",
    1449                 :            :                        s1->name);*/
    1450                 :            :           break;
    1451                 :            : 
    1452                 :            :         case 0:
    1453                 :            :           break;
    1454                 :            : 
    1455                 :          0 :         default:
    1456                 :          0 :           gfc_internal_error ("check_dummy_characteristics: Unexpected result "
    1457                 :            :                               "%i of gfc_dep_compare_expr", compval);
    1458                 :            :           break;
    1459                 :            :       }
    1460                 :            :     }
    1461                 :            : 
    1462                 :            :   /* Check array shape.  */
    1463                 :      28636 :   if (s1->as && s2->as)
    1464                 :            :     {
    1465                 :       3820 :       int i, compval;
    1466                 :       3820 :       gfc_expr *shape1, *shape2;
    1467                 :            : 
    1468                 :       3820 :       if (s1->as->type != s2->as->type)
    1469                 :            :         {
    1470                 :          3 :           snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
    1471                 :            :                     s1->name);
    1472                 :          3 :           return false;
    1473                 :            :         }
    1474                 :            : 
    1475                 :       3817 :       if (s1->as->corank != s2->as->corank)
    1476                 :            :         {
    1477                 :          1 :           snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
    1478                 :            :                     s1->name, s1->as->corank, s2->as->corank);
    1479                 :          1 :           return false;
    1480                 :            :         }
    1481                 :            : 
    1482                 :       3816 :       if (s1->as->type == AS_EXPLICIT)
    1483                 :        299 :         for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
    1484                 :            :           {
    1485                 :        190 :             shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
    1486                 :            :                                   gfc_copy_expr (s1->as->lower[i]));
    1487                 :        190 :             shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
    1488                 :        190 :                                   gfc_copy_expr (s2->as->lower[i]));
    1489                 :        190 :             compval = gfc_dep_compare_expr (shape1, shape2);
    1490                 :        190 :             gfc_free_expr (shape1);
    1491                 :        190 :             gfc_free_expr (shape2);
    1492                 :        190 :             switch (compval)
    1493                 :            :             {
    1494                 :          2 :               case -1:
    1495                 :          2 :               case  1:
    1496                 :          2 :               case -3:
    1497                 :          2 :                 if (i < s1->as->rank)
    1498                 :          2 :                   snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
    1499                 :            :                             " argument '%s'", i + 1, s1->name);
    1500                 :            :                 else
    1501                 :          0 :                   snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
    1502                 :          0 :                             "of argument '%s'", i - s1->as->rank + 1, s1->name);
    1503                 :          2 :                 return false;
    1504                 :            : 
    1505                 :            :               case -2:
    1506                 :            :                 /* FIXME: Implement a warning for this case.
    1507                 :            :                 gfc_warning (0, "Possible shape mismatch in argument %qs",
    1508                 :            :                             s1->name);*/
    1509                 :            :                 break;
    1510                 :            : 
    1511                 :            :               case 0:
    1512                 :            :                 break;
    1513                 :            : 
    1514                 :          0 :               default:
    1515                 :          0 :                 gfc_internal_error ("check_dummy_characteristics: Unexpected "
    1516                 :            :                                     "result %i of gfc_dep_compare_expr",
    1517                 :            :                                     compval);
    1518                 :        188 :                 break;
    1519                 :            :             }
    1520                 :            :           }
    1521                 :            :     }
    1522                 :            : 
    1523                 :            :   return true;
    1524                 :            : }
    1525                 :            : 
    1526                 :            : 
    1527                 :            : /* Check if the characteristics of two function results match,
    1528                 :            :    cf. F08:12.3.3.  */
    1529                 :            : 
    1530                 :            : bool
    1531                 :      18607 : gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
    1532                 :            :                               char *errmsg, int err_len)
    1533                 :            : {
    1534                 :      18607 :   gfc_symbol *r1, *r2;
    1535                 :            : 
    1536                 :      18607 :   if (s1->ts.interface && s1->ts.interface->result)
    1537                 :            :     r1 = s1->ts.interface->result;
    1538                 :            :   else
    1539                 :      18465 :     r1 = s1->result ? s1->result : s1;
    1540                 :            : 
    1541                 :      18607 :   if (s2->ts.interface && s2->ts.interface->result)
    1542                 :            :     r2 = s2->ts.interface->result;
    1543                 :            :   else
    1544                 :      18465 :     r2 = s2->result ? s2->result : s2;
    1545                 :            : 
    1546                 :      18607 :   if (r1->ts.type == BT_UNKNOWN)
    1547                 :            :     return true;
    1548                 :            : 
    1549                 :            :   /* Check type and rank.  */
    1550                 :      18430 :   if (!compare_type_characteristics (r1, r2))
    1551                 :            :     {
    1552                 :         20 :       snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
    1553                 :            :                 gfc_typename (&r1->ts), gfc_typename (&r2->ts));
    1554                 :         20 :       return false;
    1555                 :            :     }
    1556                 :      18410 :   if (!compare_rank (r1, r2))
    1557                 :            :     {
    1558                 :          6 :       snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
    1559                 :            :                 symbol_rank (r1), symbol_rank (r2));
    1560                 :          3 :       return false;
    1561                 :            :     }
    1562                 :            : 
    1563                 :            :   /* Check ALLOCATABLE attribute.  */
    1564                 :      18407 :   if (r1->attr.allocatable != r2->attr.allocatable)
    1565                 :            :     {
    1566                 :          2 :       snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
    1567                 :            :                 "function result");
    1568                 :          2 :       return false;
    1569                 :            :     }
    1570                 :            : 
    1571                 :            :   /* Check POINTER attribute.  */
    1572                 :      18405 :   if (r1->attr.pointer != r2->attr.pointer)
    1573                 :            :     {
    1574                 :          1 :       snprintf (errmsg, err_len, "POINTER attribute mismatch in "
    1575                 :            :                 "function result");
    1576                 :          1 :       return false;
    1577                 :            :     }
    1578                 :            : 
    1579                 :            :   /* Check CONTIGUOUS attribute.  */
    1580                 :      18404 :   if (r1->attr.contiguous != r2->attr.contiguous)
    1581                 :            :     {
    1582                 :          1 :       snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
    1583                 :            :                 "function result");
    1584                 :          1 :       return false;
    1585                 :            :     }
    1586                 :            : 
    1587                 :            :   /* Check PROCEDURE POINTER attribute.  */
    1588                 :      18403 :   if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
    1589                 :            :     {
    1590                 :          3 :       snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
    1591                 :            :                 "function result");
    1592                 :          3 :       return false;
    1593                 :            :     }
    1594                 :            : 
    1595                 :            :   /* Check string length.  */
    1596                 :      18400 :   if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
    1597                 :            :     {
    1598                 :       1249 :       if (r1->ts.deferred != r2->ts.deferred)
    1599                 :            :         {
    1600                 :          0 :           snprintf (errmsg, err_len, "Character length mismatch "
    1601                 :            :                     "in function result");
    1602                 :          0 :           return false;
    1603                 :            :         }
    1604                 :            : 
    1605                 :       1249 :       if (r1->ts.u.cl->length && r2->ts.u.cl->length)
    1606                 :            :         {
    1607                 :        753 :           int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
    1608                 :            :                                               r2->ts.u.cl->length);
    1609                 :        753 :           switch (compval)
    1610                 :            :           {
    1611                 :          6 :             case -1:
    1612                 :          6 :             case  1:
    1613                 :          6 :             case -3:
    1614                 :          6 :               snprintf (errmsg, err_len, "Character length mismatch "
    1615                 :            :                         "in function result");
    1616                 :          6 :               return false;
    1617                 :            : 
    1618                 :            :             case -2:
    1619                 :            :               /* FIXME: Implement a warning for this case.
    1620                 :            :               snprintf (errmsg, err_len, "Possible character length mismatch "
    1621                 :            :                         "in function result");*/
    1622                 :            :               break;
    1623                 :            : 
    1624                 :            :             case 0:
    1625                 :            :               break;
    1626                 :            : 
    1627                 :          0 :             default:
    1628                 :          0 :               gfc_internal_error ("check_result_characteristics (1): Unexpected "
    1629                 :            :                                   "result %i of gfc_dep_compare_expr", compval);
    1630                 :            :               break;
    1631                 :            :           }
    1632                 :            :         }
    1633                 :            :     }
    1634                 :            : 
    1635                 :            :   /* Check array shape.  */
    1636                 :      18394 :   if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
    1637                 :            :     {
    1638                 :        543 :       int i, compval;
    1639                 :        543 :       gfc_expr *shape1, *shape2;
    1640                 :            : 
    1641                 :        543 :       if (r1->as->type != r2->as->type)
    1642                 :            :         {
    1643                 :          0 :           snprintf (errmsg, err_len, "Shape mismatch in function result");
    1644                 :          0 :           return false;
    1645                 :            :         }
    1646                 :            : 
    1647                 :        543 :       if (r1->as->type == AS_EXPLICIT)
    1648                 :       1367 :         for (i = 0; i < r1->as->rank + r1->as->corank; i++)
    1649                 :            :           {
    1650                 :        825 :             shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
    1651                 :            :                                    gfc_copy_expr (r1->as->lower[i]));
    1652                 :        825 :             shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
    1653                 :        825 :                                    gfc_copy_expr (r2->as->lower[i]));
    1654                 :        825 :             compval = gfc_dep_compare_expr (shape1, shape2);
    1655                 :        825 :             gfc_free_expr (shape1);
    1656                 :        825 :             gfc_free_expr (shape2);
    1657                 :        825 :             switch (compval)
    1658                 :            :             {
    1659                 :          1 :               case -1:
    1660                 :          1 :               case  1:
    1661                 :          1 :               case -3:
    1662                 :          1 :                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
    1663                 :            :                           "function result", i + 1);
    1664                 :          1 :                 return false;
    1665                 :            : 
    1666                 :            :               case -2:
    1667                 :            :                 /* FIXME: Implement a warning for this case.
    1668                 :            :                 gfc_warning (0, "Possible shape mismatch in return value");*/
    1669                 :            :                 break;
    1670                 :            : 
    1671                 :            :               case 0:
    1672                 :            :                 break;
    1673                 :            : 
    1674                 :          0 :               default:
    1675                 :          0 :                 gfc_internal_error ("check_result_characteristics (2): "
    1676                 :            :                                     "Unexpected result %i of "
    1677                 :            :                                     "gfc_dep_compare_expr", compval);
    1678                 :        824 :                 break;
    1679                 :            :             }
    1680                 :            :           }
    1681                 :            :     }
    1682                 :            : 
    1683                 :            :   return true;
    1684                 :            : }
    1685                 :            : 
    1686                 :            : 
    1687                 :            : /* 'Compare' two formal interfaces associated with a pair of symbols.
    1688                 :            :    We return true if there exists an actual argument list that
    1689                 :            :    would be ambiguous between the two interfaces, zero otherwise.
    1690                 :            :    'strict_flag' specifies whether all the characteristics are
    1691                 :            :    required to match, which is not the case for ambiguity checks.
    1692                 :            :    'p1' and 'p2' are the PASS arguments of both procedures (if applicable).  */
    1693                 :            : 
    1694                 :            : bool
    1695                 :     351161 : gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
    1696                 :            :                         int generic_flag, int strict_flag,
    1697                 :            :                         char *errmsg, int err_len,
    1698                 :            :                         const char *p1, const char *p2)
    1699                 :            : {
    1700                 :     351161 :   gfc_formal_arglist *f1, *f2;
    1701                 :            : 
    1702                 :     351161 :   gcc_assert (name2 != NULL);
    1703                 :            : 
    1704                 :     649362 :   if (s1->attr.function && (s2->attr.subroutine
    1705                 :     298198 :       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
    1706                 :     351166 :           && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
    1707                 :            :     {
    1708                 :          3 :       if (errmsg != NULL)
    1709                 :          3 :         snprintf (errmsg, err_len, "'%s' is not a function", name2);
    1710                 :          3 :       return false;
    1711                 :            :     }
    1712                 :            : 
    1713                 :     351158 :   if (s1->attr.subroutine && s2->attr.function)
    1714                 :            :     {
    1715                 :          5 :       if (errmsg != NULL)
    1716                 :          5 :         snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
    1717                 :          5 :       return false;
    1718                 :            :     }
    1719                 :            : 
    1720                 :            :   /* Do strict checks on all characteristics
    1721                 :            :      (for dummy procedures and procedure pointer assignments).  */
    1722                 :     351153 :   if (!generic_flag && strict_flag)
    1723                 :            :     {
    1724                 :      28181 :       if (s1->attr.function && s2->attr.function)
    1725                 :            :         {
    1726                 :            :           /* If both are functions, check result characteristics.  */
    1727                 :       8884 :           if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
    1728                 :       8884 :               || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
    1729                 :         26 :             return false;
    1730                 :            :         }
    1731                 :            : 
    1732                 :      28155 :       if (s1->attr.pure && !s2->attr.pure)
    1733                 :            :         {
    1734                 :          2 :           snprintf (errmsg, err_len, "Mismatch in PURE attribute");
    1735                 :          2 :           return false;
    1736                 :            :         }
    1737                 :      28153 :       if (s1->attr.elemental && !s2->attr.elemental)
    1738                 :            :         {
    1739                 :          0 :           snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
    1740                 :          0 :           return false;
    1741                 :            :         }
    1742                 :            :     }
    1743                 :            : 
    1744                 :     351125 :   if (s1->attr.if_source == IFSRC_UNKNOWN
    1745                 :     335890 :       || s2->attr.if_source == IFSRC_UNKNOWN)
    1746                 :            :     return true;
    1747                 :            : 
    1748                 :     335818 :   f1 = gfc_sym_get_dummy_args (s1);
    1749                 :     335818 :   f2 = gfc_sym_get_dummy_args (s2);
    1750                 :            : 
    1751                 :            :   /* Special case: No arguments.  */
    1752                 :     335818 :   if (f1 == NULL && f2 == NULL)
    1753                 :            :     return true;
    1754                 :            : 
    1755                 :     335144 :   if (generic_flag)
    1756                 :            :     {
    1757                 :     321062 :       if (count_types_test (f1, f2, p1, p2)
    1758                 :     321062 :           || count_types_test (f2, f1, p2, p1))
    1759                 :     304284 :         return false;
    1760                 :            : 
    1761                 :            :       /* Special case: alternate returns.  If both f1->sym and f2->sym are
    1762                 :            :          NULL, then the leading formal arguments are alternate returns.
    1763                 :            :          The previous conditional should catch argument lists with
    1764                 :            :          different number of argument.  */
    1765                 :      16778 :       if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
    1766                 :            :         return true;
    1767                 :            : 
    1768                 :      16775 :       if (generic_correspondence (f1, f2, p1, p2)
    1769                 :      16775 :           || generic_correspondence (f2, f1, p2, p1))
    1770                 :      16754 :         return false;
    1771                 :            :     }
    1772                 :            :   else
    1773                 :            :     /* Perform the abbreviated correspondence test for operators (the
    1774                 :            :        arguments cannot be optional and are always ordered correctly).
    1775                 :            :        This is also done when comparing interfaces for dummy procedures and in
    1776                 :            :        procedure pointer assignments.  */
    1777                 :            : 
    1778                 :      40821 :     for (; f1 || f2; f1 = f1->next, f2 = f2->next)
    1779                 :            :       {
    1780                 :            :         /* Check existence.  */
    1781                 :      28673 :         if (f1 == NULL || f2 == NULL)
    1782                 :            :           {
    1783                 :          6 :             if (errmsg != NULL)
    1784                 :          2 :               snprintf (errmsg, err_len, "'%s' has the wrong number of "
    1785                 :            :                         "arguments", name2);
    1786                 :          6 :             return false;
    1787                 :            :           }
    1788                 :            : 
    1789                 :      28667 :         if (strict_flag)
    1790                 :            :           {
    1791                 :            :             /* Check all characteristics.  */
    1792                 :      26569 :             if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
    1793                 :            :                                               errmsg, err_len))
    1794                 :            :               return false;
    1795                 :            :           }
    1796                 :            :         else
    1797                 :            :           {
    1798                 :            :             /* Operators: Only check type and rank of arguments.  */
    1799                 :       2098 :             if (!compare_type (f2->sym, f1->sym))
    1800                 :            :               {
    1801                 :       1866 :                 if (errmsg != NULL)
    1802                 :          0 :                   snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
    1803                 :          0 :                             "(%s/%s)", f1->sym->name,
    1804                 :          0 :                             gfc_typename (&f1->sym->ts),
    1805                 :          0 :                             gfc_typename (&f2->sym->ts));
    1806                 :       1866 :                 return false;
    1807                 :            :               }
    1808                 :        232 :             if (!compare_rank (f2->sym, f1->sym))
    1809                 :            :               {
    1810                 :         28 :                 if (errmsg != NULL)
    1811                 :          0 :                   snprintf (errmsg, err_len, "Rank mismatch in argument "
    1812                 :            :                             "'%s' (%i/%i)", f1->sym->name,
    1813                 :            :                             symbol_rank (f1->sym), symbol_rank (f2->sym));
    1814                 :         28 :                 return false;
    1815                 :            :               }
    1816                 :        204 :             if ((gfc_option.allow_std & GFC_STD_F2008)
    1817                 :        204 :                 && (compare_ptr_alloc(f1->sym, f2->sym)
    1818                 :      26942 :                     || compare_ptr_alloc(f2->sym, f1->sym)))
    1819                 :            :               {
    1820                 :          2 :                 if (errmsg != NULL)
    1821                 :          0 :                   snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE "
    1822                 :            :                             "attribute in argument '%s' ", f1->sym->name);
    1823                 :          2 :                 return false;
    1824                 :            :               }
    1825                 :            :           }
    1826                 :            :       }
    1827                 :            : 
    1828                 :            :   return true;
    1829                 :            : }
    1830                 :            : 
    1831                 :            : 
    1832                 :            : /* Given a pointer to an interface pointer, remove duplicate
    1833                 :            :    interfaces and make sure that all symbols are either functions
    1834                 :            :    or subroutines, and all of the same kind.  Returns true if
    1835                 :            :    something goes wrong.  */
    1836                 :            : 
    1837                 :            : static bool
    1838                 :    4387310 : check_interface0 (gfc_interface *p, const char *interface_name)
    1839                 :            : {
    1840                 :    4387310 :   gfc_interface *psave, *q, *qlast;
    1841                 :            : 
    1842                 :    4387310 :   psave = p;
    1843                 :    4470330 :   for (; p; p = p->next)
    1844                 :            :     {
    1845                 :            :       /* Make sure all symbols in the interface have been defined as
    1846                 :            :          functions or subroutines.  */
    1847                 :      83035 :       if (((!p->sym->attr.function && !p->sym->attr.subroutine)
    1848                 :      63922 :            || !p->sym->attr.if_source)
    1849                 :      19116 :           && !gfc_fl_struct (p->sym->attr.flavor))
    1850                 :            :         {
    1851                 :         11 :           const char *guessed
    1852                 :         11 :             = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
    1853                 :            : 
    1854                 :         11 :           if (p->sym->attr.external)
    1855                 :          5 :             if (guessed)
    1856                 :          5 :               gfc_error ("Procedure %qs in %s at %L has no explicit interface"
    1857                 :            :                          "; did you mean %qs?",
    1858                 :            :                          p->sym->name, interface_name, &p->sym->declared_at,
    1859                 :            :                          guessed);
    1860                 :            :             else
    1861                 :          0 :               gfc_error ("Procedure %qs in %s at %L has no explicit interface",
    1862                 :            :                          p->sym->name, interface_name, &p->sym->declared_at);
    1863                 :            :           else
    1864                 :          6 :             if (guessed)
    1865                 :          3 :               gfc_error ("Procedure %qs in %s at %L is neither function nor "
    1866                 :            :                          "subroutine; did you mean %qs?", p->sym->name,
    1867                 :            :                         interface_name, &p->sym->declared_at, guessed);
    1868                 :            :             else
    1869                 :          3 :               gfc_error ("Procedure %qs in %s at %L is neither function nor "
    1870                 :            :                          "subroutine", p->sym->name, interface_name,
    1871                 :            :                         &p->sym->declared_at);
    1872                 :         11 :           return true;
    1873                 :            :         }
    1874                 :            : 
    1875                 :            :       /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
    1876                 :      83024 :       if ((psave->sym->attr.function && !p->sym->attr.function
    1877                 :         90 :            && !gfc_fl_struct (p->sym->attr.flavor))
    1878                 :      83023 :           || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
    1879                 :            :         {
    1880                 :          2 :           if (!gfc_fl_struct (p->sym->attr.flavor))
    1881                 :          2 :             gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
    1882                 :            :                        " or all FUNCTIONs", interface_name,
    1883                 :            :                        &p->sym->declared_at);
    1884                 :          0 :           else if (p->sym->attr.flavor == FL_DERIVED)
    1885                 :          0 :             gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
    1886                 :            :                        "generic name is also the name of a derived type",
    1887                 :            :                        interface_name, &p->sym->declared_at);
    1888                 :          2 :           return true;
    1889                 :            :         }
    1890                 :            : 
    1891                 :            :       /* F2003, C1207. F2008, C1207.  */
    1892                 :      83022 :       if (p->sym->attr.proc == PROC_INTERNAL
    1893                 :      83022 :           && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
    1894                 :            :                               "%qs in %s at %L", p->sym->name,
    1895                 :            :                               interface_name, &p->sym->declared_at))
    1896                 :            :         return true;
    1897                 :            :     }
    1898                 :            :   p = psave;
    1899                 :            : 
    1900                 :            :   /* Remove duplicate interfaces in this interface list.  */
    1901                 :    4467820 :   for (; p; p = p->next)
    1902                 :            :     {
    1903                 :      80523 :       qlast = p;
    1904                 :            : 
    1905                 :     254452 :       for (q = p->next; q;)
    1906                 :            :         {
    1907                 :     173929 :           if (p->sym != q->sym)
    1908                 :            :             {
    1909                 :     171435 :               qlast = q;
    1910                 :     171435 :               q = q->next;
    1911                 :            :             }
    1912                 :            :           else
    1913                 :            :             {
    1914                 :            :               /* Duplicate interface.  */
    1915                 :       2494 :               qlast->next = q->next;
    1916                 :       2494 :               free (q);
    1917                 :       2494 :               q = qlast->next;
    1918                 :            :             }
    1919                 :            :         }
    1920                 :            :     }
    1921                 :            : 
    1922                 :            :   return false;
    1923                 :            : }
    1924                 :            : 
    1925                 :            : 
    1926                 :            : /* Check lists of interfaces to make sure that no two interfaces are
    1927                 :            :    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
    1928                 :            : 
    1929                 :            : static bool
    1930                 :    8202380 : check_interface1 (gfc_interface *p, gfc_interface *q0,
    1931                 :            :                   int generic_flag, const char *interface_name,
    1932                 :            :                   bool referenced)
    1933                 :            : {
    1934                 :    8284560 :   gfc_interface *q;
    1935                 :    8284560 :   for (; p; p = p->next)
    1936                 :     485627 :     for (q = q0; q; q = q->next)
    1937                 :            :       {
    1938                 :     403447 :         if (p->sym == q->sym)
    1939                 :      80489 :           continue;             /* Duplicates OK here.  */
    1940                 :            : 
    1941                 :     322958 :         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
    1942                 :         99 :           continue;
    1943                 :            : 
    1944                 :     322731 :         if (!gfc_fl_struct (p->sym->attr.flavor)
    1945                 :     322731 :             && !gfc_fl_struct (q->sym->attr.flavor)
    1946                 :     645466 :             && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
    1947                 :            :                                        generic_flag, 0, NULL, 0, NULL, NULL))
    1948                 :            :           {
    1949                 :         26 :             if (referenced)
    1950                 :         23 :               gfc_error ("Ambiguous interfaces in %s for %qs at %L "
    1951                 :            :                          "and %qs at %L", interface_name,
    1952                 :         23 :                          q->sym->name, &q->sym->declared_at,
    1953                 :         23 :                          p->sym->name, &p->sym->declared_at);
    1954                 :          3 :             else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
    1955                 :          1 :               gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
    1956                 :            :                          "and %qs at %L", interface_name,
    1957                 :            :                          q->sym->name, &q->sym->declared_at,
    1958                 :            :                          p->sym->name, &p->sym->declared_at);
    1959                 :            :             else
    1960                 :          2 :               gfc_warning (0, "Although not referenced, %qs has ambiguous "
    1961                 :            :                            "interfaces at %L", interface_name, &p->where);
    1962                 :         26 :             return true;
    1963                 :            :           }
    1964                 :            :       }
    1965                 :            :   return false;
    1966                 :            : }
    1967                 :            : 
    1968                 :            : 
    1969                 :            : /* Check the generic and operator interfaces of symbols to make sure
    1970                 :            :    that none of the interfaces conflict.  The check has to be done
    1971                 :            :    after all of the symbols are actually loaded.  */
    1972                 :            : 
    1973                 :            : static void
    1974                 :     806149 : check_sym_interfaces (gfc_symbol *sym)
    1975                 :            : {
    1976                 :     806149 :   char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("generic interface ''")];
    1977                 :     806149 :   gfc_interface *p;
    1978                 :            : 
    1979                 :     806149 :   if (sym->ns != gfc_current_ns)
    1980                 :      34786 :     return;
    1981                 :            : 
    1982                 :     771380 :   if (sym->generic != NULL)
    1983                 :            :     {
    1984                 :      37888 :       sprintf (interface_name, "generic interface '%s'", sym->name);
    1985                 :      37888 :       if (check_interface0 (sym->generic, interface_name))
    1986                 :            :         return;
    1987                 :            : 
    1988                 :     116001 :       for (p = sym->generic; p; p = p->next)
    1989                 :            :         {
    1990                 :      78130 :           if (p->sym->attr.mod_proc
    1991                 :      78130 :               && !p->sym->attr.module_procedure
    1992                 :        967 :               && (p->sym->attr.if_source != IFSRC_DECL
    1993                 :        963 :                   || p->sym->attr.procedure))
    1994                 :            :             {
    1995                 :          4 :               gfc_error ("%qs at %L is not a module procedure",
    1996                 :            :                          p->sym->name, &p->where);
    1997                 :          4 :               return;
    1998                 :            :             }
    1999                 :            :         }
    2000                 :            : 
    2001                 :            :       /* Originally, this test was applied to host interfaces too;
    2002                 :            :          this is incorrect since host associated symbols, from any
    2003                 :            :          source, cannot be ambiguous with local symbols.  */
    2004                 :      37871 :       check_interface1 (sym->generic, sym->generic, 1, interface_name,
    2005                 :      37871 :                         sym->attr.referenced || !sym->attr.use_assoc);
    2006                 :            :     }
    2007                 :            : }
    2008                 :            : 
    2009                 :            : 
    2010                 :            : static void
    2011                 :        270 : check_uop_interfaces (gfc_user_op *uop)
    2012                 :            : {
    2013                 :        270 :   char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
    2014                 :        270 :   gfc_user_op *uop2;
    2015                 :        270 :   gfc_namespace *ns;
    2016                 :            : 
    2017                 :        270 :   sprintf (interface_name, "operator interface '%s'", uop->name);
    2018                 :        270 :   if (check_interface0 (uop->op, interface_name))
    2019                 :          1 :     return;
    2020                 :            : 
    2021                 :        548 :   for (ns = gfc_current_ns; ns; ns = ns->parent)
    2022                 :            :     {
    2023                 :        279 :       uop2 = gfc_find_uop (uop->name, ns);
    2024                 :        279 :       if (uop2 == NULL)
    2025                 :         10 :         continue;
    2026                 :            : 
    2027                 :        269 :       check_interface1 (uop->op, uop2->op, 0,
    2028                 :            :                         interface_name, true);
    2029                 :            :     }
    2030                 :            : }
    2031                 :            : 
    2032                 :            : /* Given an intrinsic op, return an equivalent op if one exists,
    2033                 :            :    or INTRINSIC_NONE otherwise.  */
    2034                 :            : 
    2035                 :            : gfc_intrinsic_op
    2036                 :    5652220 : gfc_equivalent_op (gfc_intrinsic_op op)
    2037                 :            : {
    2038                 :    5652220 :   switch(op)
    2039                 :            :     {
    2040                 :            :     case INTRINSIC_EQ:
    2041                 :            :       return INTRINSIC_EQ_OS;
    2042                 :            : 
    2043                 :            :     case INTRINSIC_EQ_OS:
    2044                 :            :       return INTRINSIC_EQ;
    2045                 :            : 
    2046                 :            :     case INTRINSIC_NE:
    2047                 :            :       return INTRINSIC_NE_OS;
    2048                 :            : 
    2049                 :            :     case INTRINSIC_NE_OS:
    2050                 :            :       return INTRINSIC_NE;
    2051                 :            : 
    2052                 :            :     case INTRINSIC_GT:
    2053                 :            :       return INTRINSIC_GT_OS;
    2054                 :            : 
    2055                 :            :     case INTRINSIC_GT_OS:
    2056                 :            :       return INTRINSIC_GT;
    2057                 :            : 
    2058                 :            :     case INTRINSIC_GE:
    2059                 :            :       return INTRINSIC_GE_OS;
    2060                 :            : 
    2061                 :            :     case INTRINSIC_GE_OS:
    2062                 :            :       return INTRINSIC_GE;
    2063                 :            : 
    2064                 :            :     case INTRINSIC_LT:
    2065                 :            :       return INTRINSIC_LT_OS;
    2066                 :            : 
    2067                 :            :     case INTRINSIC_LT_OS:
    2068                 :            :       return INTRINSIC_LT;
    2069                 :            : 
    2070                 :            :     case INTRINSIC_LE:
    2071                 :            :       return INTRINSIC_LE_OS;
    2072                 :            : 
    2073                 :            :     case INTRINSIC_LE_OS:
    2074                 :            :       return INTRINSIC_LE;
    2075                 :            : 
    2076                 :            :     default:
    2077                 :            :       return INTRINSIC_NONE;
    2078                 :            :     }
    2079                 :            : }
    2080                 :            : 
    2081                 :            : /* For the namespace, check generic, user operator and intrinsic
    2082                 :            :    operator interfaces for consistency and to remove duplicate
    2083                 :            :    interfaces.  We traverse the whole namespace, counting on the fact
    2084                 :            :    that most symbols will not have generic or operator interfaces.  */
    2085                 :            : 
    2086                 :            : void
    2087                 :     161082 : gfc_check_interfaces (gfc_namespace *ns)
    2088                 :            : {
    2089                 :     161082 :   gfc_namespace *old_ns, *ns2;
    2090                 :     161082 :   char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
    2091                 :     161082 :   int i;
    2092                 :            : 
    2093                 :     161082 :   old_ns = gfc_current_ns;
    2094                 :     161082 :   gfc_current_ns = ns;
    2095                 :            : 
    2096                 :     161082 :   gfc_traverse_ns (ns, check_sym_interfaces);
    2097                 :            : 
    2098                 :     161082 :   gfc_traverse_user_op (ns, check_uop_interfaces);
    2099                 :            : 
    2100                 :    4671310 :   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    2101                 :            :     {
    2102                 :    4510230 :       if (i == INTRINSIC_USER)
    2103                 :     161079 :         continue;
    2104                 :            : 
    2105                 :    4349150 :       if (i == INTRINSIC_ASSIGN)
    2106                 :     161079 :         strcpy (interface_name, "intrinsic assignment operator");
    2107                 :            :       else
    2108                 :    4188070 :         sprintf (interface_name, "intrinsic '%s' operator",
    2109                 :            :                  gfc_op2string ((gfc_intrinsic_op) i));
    2110                 :            : 
    2111                 :    4349150 :       if (check_interface0 (ns->op[i], interface_name))
    2112                 :          0 :         continue;
    2113                 :            : 
    2114                 :    4349150 :       if (ns->op[i])
    2115                 :       1581 :         gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
    2116                 :            :                                       ns->op[i]->where);
    2117                 :            : 
    2118                 :   10001300 :       for (ns2 = ns; ns2; ns2 = ns2->parent)
    2119                 :            :         {
    2120                 :    5652170 :           gfc_intrinsic_op other_op;
    2121                 :            : 
    2122                 :    5652170 :           if (check_interface1 (ns->op[i], ns2->op[i], 0,
    2123                 :            :                                 interface_name, true))
    2124                 :          3 :             goto done;
    2125                 :            : 
    2126                 :            :           /* i should be gfc_intrinsic_op, but has to be int with this cast
    2127                 :            :              here for stupid C++ compatibility rules.  */
    2128                 :    5652170 :           other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
    2129                 :    5652170 :           if (other_op != INTRINSIC_NONE
    2130                 :    5652170 :             &&  check_interface1 (ns->op[i], ns2->op[other_op],
    2131                 :            :                                   0, interface_name, true))
    2132                 :          0 :             goto done;
    2133                 :            :         }
    2134                 :            :     }
    2135                 :            : 
    2136                 :     161079 : done:
    2137                 :     161082 :   gfc_current_ns = old_ns;
    2138                 :     161082 : }
    2139                 :            : 
    2140                 :            : 
    2141                 :            : /* Given a symbol of a formal argument list and an expression, if the
    2142                 :            :    formal argument is allocatable, check that the actual argument is
    2143                 :            :    allocatable. Returns true if compatible, zero if not compatible.  */
    2144                 :            : 
    2145                 :            : static bool
    2146                 :     150440 : compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
    2147                 :            : {
    2148                 :     150440 :   if (formal->attr.allocatable
    2149                 :     150440 :       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
    2150                 :            :     {
    2151                 :       1986 :       symbol_attribute attr = gfc_expr_attr (actual);
    2152                 :       1986 :       if (actual->ts.type == BT_CLASS && !attr.class_ok)
    2153                 :          8 :         return true;
    2154                 :       1984 :       else if (!attr.allocatable)
    2155                 :            :         return false;
    2156                 :            :     }
    2157                 :            : 
    2158                 :            :   return true;
    2159                 :            : }
    2160                 :            : 
    2161                 :            : 
    2162                 :            : /* Given a symbol of a formal argument list and an expression, if the
    2163                 :            :    formal argument is a pointer, see if the actual argument is a
    2164                 :            :    pointer. Returns nonzero if compatible, zero if not compatible.  */
    2165                 :            : 
    2166                 :            : static int
    2167                 :     150988 : compare_pointer (gfc_symbol *formal, gfc_expr *actual)
    2168                 :            : {
    2169                 :     150988 :   symbol_attribute attr;
    2170                 :            : 
    2171                 :     150988 :   if (formal->attr.pointer
    2172                 :     148529 :       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
    2173                 :     159751 :           && CLASS_DATA (formal)->attr.class_pointer))
    2174                 :            :     {
    2175                 :       2971 :       attr = gfc_expr_attr (actual);
    2176                 :            : 
    2177                 :            :       /* Fortran 2008 allows non-pointer actual arguments.  */
    2178                 :       2971 :       if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
    2179                 :            :         return 2;
    2180                 :            : 
    2181                 :       2717 :       if (!attr.pointer)
    2182                 :         10 :         return 0;
    2183                 :            :     }
    2184                 :            : 
    2185                 :            :   return 1;
    2186                 :            : }
    2187                 :            : 
    2188                 :            : 
    2189                 :            : /* Emit clear error messages for rank mismatch.  */
    2190                 :            : 
    2191                 :            : static void
    2192                 :        105 : argument_rank_mismatch (const char *name, locus *where,
    2193                 :            :                         int rank1, int rank2, locus *where_formal)
    2194                 :            : {
    2195                 :            : 
    2196                 :            :   /* TS 29113, C407b.  */
    2197                 :        105 :   if (where_formal == NULL)
    2198                 :            :     {
    2199                 :         97 :       if (rank2 == -1)
    2200                 :          1 :         gfc_error ("The assumed-rank array at %L requires that the dummy "
    2201                 :            :                    "argument %qs has assumed-rank", where, name);
    2202                 :         96 :       else if (rank1 == 0)
    2203                 :         15 :         gfc_error_opt (0, "Rank mismatch in argument %qs "
    2204                 :            :                        "at %L (scalar and rank-%d)", name, where, rank2);
    2205                 :         81 :       else if (rank2 == 0)
    2206                 :         77 :         gfc_error_opt (0, "Rank mismatch in argument %qs "
    2207                 :            :                        "at %L (rank-%d and scalar)", name, where, rank1);
    2208                 :            :       else
    2209                 :          4 :         gfc_error_opt (0, "Rank mismatch in argument %qs "
    2210                 :            :                        "at %L (rank-%d and rank-%d)", name, where, rank1,
    2211                 :            :                        rank2);
    2212                 :            :     }
    2213                 :            :   else
    2214                 :            :     {
    2215                 :          8 :       gcc_assert (rank2 != -1);
    2216                 :          8 :       if (rank1 == 0)
    2217                 :          6 :         gfc_error_opt (0, "Rank mismatch between actual argument at %L "
    2218                 :            :                        "and actual argument at %L (scalar and rank-%d)",
    2219                 :            :                        where, where_formal, rank2);
    2220                 :          2 :       else if (rank2 == 0)
    2221                 :          2 :         gfc_error_opt (0, "Rank mismatch between actual argument at %L "
    2222                 :            :                        "and actual argument at %L (rank-%d and scalar)",
    2223                 :            :                        where, where_formal, rank1);
    2224                 :            :       else
    2225                 :          0 :         gfc_error_opt (0, "Rank mismatch between actual argument at %L "
    2226                 :            :                        "and actual argument at %L (rank-%d and rank-%d)", where,
    2227                 :            :                        where_formal, rank1, rank2);
    2228                 :            :     }
    2229                 :        105 : }
    2230                 :            : 
    2231                 :            : 
    2232                 :            : /* Under certain conditions, a scalar actual argument can be passed
    2233                 :            :    to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
    2234                 :            :    This function returns true for these conditions so that an error
    2235                 :            :    or warning for this can be suppressed later.  Always return false
    2236                 :            :    for expressions with rank > 0.  */
    2237                 :            : 
    2238                 :            : bool
    2239                 :       2932 : maybe_dummy_array_arg (gfc_expr *e)
    2240                 :            : {
    2241                 :       2932 :   gfc_symbol *s;
    2242                 :       2932 :   gfc_ref *ref;
    2243                 :       2932 :   bool array_pointer = false;
    2244                 :       2932 :   bool assumed_shape = false;
    2245                 :       2932 :   bool scalar_ref = true;
    2246                 :            : 
    2247                 :       2932 :   if (e->rank > 0)
    2248                 :            :     return false;
    2249                 :            : 
    2250                 :       2926 :   if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
    2251                 :            :     return true;
    2252                 :            : 
    2253                 :            :   /* If this comes from a constructor, it has been an array element
    2254                 :            :      originally.  */
    2255                 :            : 
    2256                 :       2791 :   if (e->expr_type == EXPR_CONSTANT)
    2257                 :        580 :     return e->from_constructor;
    2258                 :            : 
    2259                 :       2211 :   if (e->expr_type != EXPR_VARIABLE)
    2260                 :            :     return false;
    2261                 :            : 
    2262                 :       2120 :   s = e->symtree->n.sym;
    2263                 :            : 
    2264                 :       2120 :   if (s->attr.dimension)
    2265                 :            :     {
    2266                 :        221 :       scalar_ref = false;
    2267                 :        221 :       array_pointer = s->attr.pointer;
    2268                 :            :     }
    2269                 :            : 
    2270                 :       2120 :   if (s->as && s->as->type == AS_ASSUMED_SHAPE)
    2271                 :          3 :     assumed_shape = true;
    2272                 :            : 
    2273                 :       2367 :   for (ref=e->ref; ref; ref=ref->next)
    2274                 :            :     {
    2275                 :        247 :       if (ref->type == REF_COMPONENT)
    2276                 :            :         {
    2277                 :         20 :           symbol_attribute *attr;
    2278                 :         20 :           attr = &ref->u.c.component->attr;
    2279                 :         20 :           if (attr->dimension)
    2280                 :            :             {
    2281                 :          2 :               array_pointer = attr->pointer;
    2282                 :          2 :               assumed_shape = false;
    2283                 :          2 :               scalar_ref = false;
    2284                 :            :             }
    2285                 :            :           else
    2286                 :            :             scalar_ref = true;
    2287                 :            :         }
    2288                 :            :     }
    2289                 :            : 
    2290                 :       2120 :   return !(scalar_ref || array_pointer || assumed_shape);
    2291                 :            : }
    2292                 :            : 
    2293                 :            : /* Given a symbol of a formal argument list and an expression, see if
    2294                 :            :    the two are compatible as arguments.  Returns true if
    2295                 :            :    compatible, false if not compatible.  */
    2296                 :            : 
    2297                 :            : static bool
    2298                 :     186610 : compare_parameter (gfc_symbol *formal, gfc_expr *actual,
    2299                 :            :                    int ranks_must_agree, int is_elemental, locus *where)
    2300                 :            : {
    2301                 :     186610 :   gfc_ref *ref;
    2302                 :     186610 :   bool rank_check, is_pointer;
    2303                 :     186610 :   char err[200];
    2304                 :     186610 :   gfc_component *ppc;
    2305                 :            : 
    2306                 :            :   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
    2307                 :            :      procs c_f_pointer or c_f_procpointer, and we need to accept most
    2308                 :            :      pointers the user could give us.  This should allow that.  */
    2309                 :     186610 :   if (formal->ts.type == BT_VOID)
    2310                 :            :     return true;
    2311                 :            : 
    2312                 :     186610 :   if (formal->ts.type == BT_DERIVED
    2313                 :      15840 :       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
    2314                 :       3118 :       && actual->ts.type == BT_DERIVED
    2315                 :       3110 :       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
    2316                 :            :     return true;
    2317                 :            : 
    2318                 :     183500 :   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
    2319                 :            :     /* Make sure the vtab symbol is present when
    2320                 :            :        the module variables are generated.  */
    2321                 :       4314 :     gfc_find_derived_vtab (actual->ts.u.derived);
    2322                 :            : 
    2323                 :     183500 :   if (actual->ts.type == BT_PROCEDURE)
    2324                 :            :     {
    2325                 :       1792 :       gfc_symbol *act_sym = actual->symtree->n.sym;
    2326                 :            : 
    2327                 :       1792 :       if (formal->attr.flavor != FL_PROCEDURE)
    2328                 :            :         {
    2329                 :          3 :           if (where)
    2330                 :          2 :             gfc_error ("Invalid procedure argument at %L", &actual->where);
    2331                 :          3 :           return false;
    2332                 :            :         }
    2333                 :            : 
    2334                 :       1789 :       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
    2335                 :            :                                    sizeof(err), NULL, NULL))
    2336                 :            :         {
    2337                 :         30 :           if (where)
    2338                 :         30 :             gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
    2339                 :            :                            " %s", formal->name, &actual->where, err);
    2340                 :         30 :           return false;
    2341                 :            :         }
    2342                 :            : 
    2343                 :       1759 :       if (formal->attr.function && !act_sym->attr.function)
    2344                 :            :         {
    2345                 :          4 :           gfc_add_function (&act_sym->attr, act_sym->name,
    2346                 :            :           &act_sym->declared_at);
    2347                 :          4 :           if (act_sym->ts.type == BT_UNKNOWN
    2348                 :          4 :               && !gfc_set_default_type (act_sym, 1, act_sym->ns))
    2349                 :            :             return false;
    2350                 :            :         }
    2351                 :       1755 :       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
    2352                 :         44 :         gfc_add_subroutine (&act_sym->attr, act_sym->name,
    2353                 :            :                             &act_sym->declared_at);
    2354                 :            : 
    2355                 :       1759 :       return true;
    2356                 :            :     }
    2357                 :            : 
    2358                 :     181708 :   ppc = gfc_get_proc_ptr_comp (actual);
    2359                 :     181708 :   if (ppc && ppc->ts.interface)
    2360                 :            :     {
    2361                 :        469 :       if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
    2362                 :            :                                    err, sizeof(err), NULL, NULL))
    2363                 :            :         {
    2364                 :          1 :           if (where)
    2365                 :          1 :             gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
    2366                 :            :                            " %s", formal->name, &actual->where, err);
    2367                 :          1 :           return false;
    2368                 :            :         }
    2369                 :            :     }
    2370                 :            : 
    2371                 :            :   /* F2008, C1241.  */
    2372                 :     181707 :   if (formal->attr.pointer && formal->attr.contiguous
    2373                 :     181707 :       && !gfc_is_simply_contiguous (actual, true, false))
    2374                 :            :     {
    2375                 :          2 :       if (where)
    2376                 :          2 :         gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
    2377                 :            :                    "must be simply contiguous", formal->name, &actual->where);
    2378                 :          2 :       return false;
    2379                 :            :     }
    2380                 :            : 
    2381                 :     181705 :   symbol_attribute actual_attr = gfc_expr_attr (actual);
    2382                 :     181705 :   if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
    2383                 :            :     return true;
    2384                 :            : 
    2385                 :        239 :   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
    2386                 :     181546 :       && actual->ts.type != BT_HOLLERITH
    2387                 :     181527 :       && formal->ts.type != BT_ASSUMED
    2388                 :     179655 :       && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
    2389                 :     179655 :       && !gfc_compare_types (&formal->ts, &actual->ts)
    2390                 :     217283 :       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
    2391                 :          0 :            && gfc_compare_derived_types (formal->ts.u.derived,
    2392                 :          0 :                                          CLASS_DATA (actual)->ts.u.derived)))
    2393                 :            :     {
    2394                 :      35594 :       if (where)
    2395                 :            :         {
    2396                 :         49 :           if (formal->attr.artificial)
    2397                 :            :             {
    2398                 :         14 :               if (!flag_allow_argument_mismatch || !formal->error)
    2399                 :          9 :                 gfc_error_opt (0, "Type mismatch between actual argument at %L "
    2400                 :            :                                "and actual argument at %L (%s/%s).",
    2401                 :            :                                &actual->where,
    2402                 :            :                                &formal->declared_at,
    2403                 :            :                                gfc_typename (actual),
    2404                 :            :                                gfc_dummy_typename (&formal->ts));
    2405                 :            : 
    2406                 :         14 :               formal->error = 1;
    2407                 :            :             }
    2408                 :            :           else
    2409                 :         35 :             gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
    2410                 :            :                            "to %s", formal->name, where, gfc_typename (actual),
    2411                 :            :                            gfc_dummy_typename (&formal->ts));
    2412                 :            :         }
    2413                 :      35594 :       return false;
    2414                 :            :     }
    2415                 :            : 
    2416                 :     146095 :   if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
    2417                 :            :     {
    2418                 :          3 :       if (where)
    2419                 :          1 :         gfc_error ("Assumed-type actual argument at %L requires that dummy "
    2420                 :            :                    "argument %qs is of assumed type", &actual->where,
    2421                 :            :                    formal->name);
    2422                 :          3 :       return false;
    2423                 :            :     }
    2424                 :            : 
    2425                 :            :   /* F2008, 12.5.2.5; IR F08/0073.  */
    2426                 :     146092 :   if (formal->ts.type == BT_CLASS && formal->attr.class_ok
    2427                 :       8768 :       && actual->expr_type != EXPR_NULL
    2428                 :       8756 :       && ((CLASS_DATA (formal)->attr.class_pointer
    2429                 :       8756 :            && formal->attr.intent != INTENT_IN)
    2430                 :       8621 :           || CLASS_DATA (formal)->attr.allocatable))
    2431                 :            :     {
    2432                 :        594 :       if (actual->ts.type != BT_CLASS)
    2433                 :            :         {
    2434                 :          2 :           if (where)
    2435                 :          2 :             gfc_error ("Actual argument to %qs at %L must be polymorphic",
    2436                 :            :                         formal->name, &actual->where);
    2437                 :          2 :           return false;
    2438                 :            :         }
    2439                 :            : 
    2440                 :        592 :       if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
    2441                 :        512 :           && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
    2442                 :            :                                          CLASS_DATA (formal)->ts.u.derived))
    2443                 :            :         {
    2444                 :          1 :           if (where)
    2445                 :          1 :             gfc_error ("Actual argument to %qs at %L must have the same "
    2446                 :            :                        "declared type", formal->name, &actual->where);
    2447                 :          1 :           return false;
    2448                 :            :         }
    2449                 :            :     }
    2450                 :            : 
    2451                 :            :   /* F08: 12.5.2.5 Allocatable and pointer dummy variables.  However, this
    2452                 :            :      is necessary also for F03, so retain error for both.
    2453                 :            :      NOTE: Other type/kind errors pre-empt this error.  Since they are F03
    2454                 :            :      compatible, no attempt has been made to channel to this one.  */
    2455                 :     146089 :   if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
    2456                 :        457 :       && (CLASS_DATA (formal)->attr.allocatable
    2457                 :        457 :           ||CLASS_DATA (formal)->attr.class_pointer))
    2458                 :            :     {
    2459                 :          0 :       if (where)
    2460                 :          0 :         gfc_error ("Actual argument to %qs at %L must be unlimited "
    2461                 :            :                    "polymorphic since the formal argument is a "
    2462                 :            :                    "pointer or allocatable unlimited polymorphic "
    2463                 :            :                    "entity [F2008: 12.5.2.5]", formal->name,
    2464                 :            :                    &actual->where);
    2465                 :          0 :       return false;
    2466                 :            :     }
    2467                 :            : 
    2468                 :     146089 :   if (formal->attr.codimension && !gfc_is_coarray (actual))
    2469                 :            :     {
    2470                 :          3 :       if (where)
    2471                 :          3 :         gfc_error ("Actual argument to %qs at %L must be a coarray",
    2472                 :            :                        formal->name, &actual->where);
    2473                 :          3 :       return false;
    2474                 :            :     }
    2475                 :            : 
    2476                 :     146086 :   if (formal->attr.codimension && formal->attr.allocatable)
    2477                 :            :     {
    2478                 :         20 :       gfc_ref *last = NULL;
    2479                 :            : 
    2480                 :         40 :       for (ref = actual->ref; ref; ref = ref->next)
    2481                 :         20 :         if (ref->type == REF_COMPONENT)
    2482                 :          0 :           last = ref;
    2483                 :            : 
    2484                 :            :       /* F2008, 12.5.2.6.  */
    2485                 :         20 :       if ((last && last->u.c.component->as->corank != formal->as->corank)
    2486                 :         20 :           || (!last
    2487                 :         20 :               && actual->symtree->n.sym->as->corank != formal->as->corank))
    2488                 :            :         {
    2489                 :          1 :           if (where)
    2490                 :          1 :             gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
    2491                 :          1 :                    formal->name, &actual->where, formal->as->corank,
    2492                 :          0 :                    last ? last->u.c.component->as->corank
    2493                 :          1 :                         : actual->symtree->n.sym->as->corank);
    2494                 :          1 :           return false;
    2495                 :            :         }
    2496                 :            :     }
    2497                 :            : 
    2498                 :     146085 :   if (formal->attr.codimension)
    2499                 :            :     {
    2500                 :            :       /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048).  */
    2501                 :            :       /* F2018, 12.5.2.8.  */
    2502                 :        174 :       if (formal->attr.dimension
    2503                 :        127 :           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
    2504                 :         88 :           && actual_attr.dimension
    2505                 :        261 :           && !gfc_is_simply_contiguous (actual, true, true))
    2506                 :            :         {
    2507                 :          2 :           if (where)
    2508                 :          2 :             gfc_error ("Actual argument to %qs at %L must be simply "
    2509                 :            :                        "contiguous or an element of such an array",
    2510                 :            :                        formal->name, &actual->where);
    2511                 :          2 :           return false;
    2512                 :            :         }
    2513                 :            : 
    2514                 :            :       /* F2008, C1303 and C1304.  */
    2515                 :        172 :       if (formal->attr.intent != INTENT_INOUT
    2516                 :        166 :           && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
    2517                 :          9 :                && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2518                 :          9 :                && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
    2519                 :        165 :               || formal->attr.lock_comp))
    2520                 :            : 
    2521                 :            :         {
    2522                 :          1 :           if (where)
    2523                 :          1 :             gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
    2524                 :            :                        "which is LOCK_TYPE or has a LOCK_TYPE component",
    2525                 :            :                        formal->name, &actual->where);
    2526                 :          1 :           return false;
    2527                 :            :         }
    2528                 :            : 
    2529                 :            :       /* TS18508, C702/C703.  */
    2530                 :        171 :       if (formal->attr.intent != INTENT_INOUT
    2531                 :        165 :           && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
    2532                 :          8 :                && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2533                 :          8 :                && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
    2534                 :        165 :               || formal->attr.event_comp))
    2535                 :            : 
    2536                 :            :         {
    2537                 :          0 :           if (where)
    2538                 :          0 :             gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
    2539                 :            :                        "which is EVENT_TYPE or has a EVENT_TYPE component",
    2540                 :            :                        formal->name, &actual->where);
    2541                 :          0 :           return false;
    2542                 :            :         }
    2543                 :            :     }
    2544                 :            : 
    2545                 :            :   /* F2008, C1239/C1240.  */
    2546                 :     146082 :   if (actual->expr_type == EXPR_VARIABLE
    2547                 :      57420 :       && (actual->symtree->n.sym->attr.asynchronous
    2548                 :      57420 :          || actual->symtree->n.sym->attr.volatile_)
    2549                 :        219 :       &&  (formal->attr.asynchronous || formal->attr.volatile_)
    2550                 :         51 :       && actual->rank && formal->as
    2551                 :         46 :       && !gfc_is_simply_contiguous (actual, true, false)
    2552                 :     146082 :       && ((formal->as->type != AS_ASSUMED_SHAPE
    2553                 :         30 :            && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
    2554                 :         28 :           || formal->attr.contiguous))
    2555                 :            :     {
    2556                 :         13 :       if (where)
    2557                 :         13 :         gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
    2558                 :            :                    "assumed-rank array without CONTIGUOUS attribute - as actual"
    2559                 :            :                    " argument at %L is not simply contiguous and both are "
    2560                 :            :                    "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
    2561                 :         13 :       return false;
    2562                 :            :     }
    2563                 :            : 
    2564                 :     146069 :   if (formal->attr.allocatable && !formal->attr.codimension
    2565                 :       1515 :       && actual_attr.codimension)
    2566                 :            :     {
    2567                 :          5 :       if (formal->attr.intent == INTENT_OUT)
    2568                 :            :         {
    2569                 :          1 :           if (where)
    2570                 :          1 :             gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
    2571                 :            :                        "INTENT(OUT) dummy argument %qs", &actual->where,
    2572                 :            :                        formal->name);
    2573                 :          1 :           return false;
    2574                 :            :         }
    2575                 :          4 :       else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
    2576                 :          1 :         gfc_warning (OPT_Wsurprising,
    2577                 :            :                      "Passing coarray at %L to allocatable, noncoarray dummy "
    2578                 :            :                      "argument %qs, which is invalid if the allocation status"
    2579                 :            :                      " is modified",  &actual->where, formal->name);
    2580                 :            :     }
    2581                 :            : 
    2582                 :            :   /* If the rank is the same or the formal argument has assumed-rank.  */
    2583                 :     296068 :   if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
    2584                 :            :     return true;
    2585                 :            : 
    2586                 :       1210 :   rank_check = where != NULL && !is_elemental && formal->as
    2587                 :       1187 :                && (formal->as->type == AS_ASSUMED_SHAPE
    2588                 :       1187 :                    || formal->as->type == AS_DEFERRED)
    2589                 :       5198 :                && actual->expr_type != EXPR_NULL;
    2590                 :            : 
    2591                 :            :   /* Skip rank checks for NO_ARG_CHECK.  */
    2592                 :       5134 :   if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
    2593                 :            :     return true;
    2594                 :            : 
    2595                 :            :   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
    2596                 :       4812 :   if (rank_check || ranks_must_agree
    2597                 :       4711 :       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
    2598                 :       4711 :       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
    2599                 :       4689 :       || (actual->rank == 0
    2600                 :        613 :           && ((formal->ts.type == BT_CLASS
    2601                 :          1 :                && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
    2602                 :        612 :               || (formal->ts.type != BT_CLASS
    2603                 :        612 :                    && formal->as->type == AS_ASSUMED_SHAPE))
    2604                 :         13 :           && actual->expr_type != EXPR_NULL)
    2605                 :       9500 :       || (actual->rank == 0 && formal->attr.dimension
    2606                 :        612 :           && gfc_is_coindexed (actual)))
    2607                 :            :     {
    2608                 :        127 :       if (where 
    2609                 :        127 :           && (!formal->attr.artificial || (!formal->maybe_array
    2610                 :          6 :                                            && !maybe_dummy_array_arg (actual))))
    2611                 :            :         {
    2612                 :         70 :           locus *where_formal;
    2613                 :         70 :           if (formal->attr.artificial)
    2614                 :          6 :             where_formal = &formal->declared_at;
    2615                 :            :           else
    2616                 :            :             where_formal = NULL;
    2617                 :            : 
    2618                 :        140 :           argument_rank_mismatch (formal->name, &actual->where,
    2619                 :            :                                   symbol_rank (formal), actual->rank,
    2620                 :            :                                   where_formal);
    2621                 :            :         }
    2622                 :        127 :       return false;
    2623                 :            :     }
    2624                 :       4685 :   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
    2625                 :            :     return true;
    2626                 :            : 
    2627                 :            :   /* At this point, we are considering a scalar passed to an array.   This
    2628                 :            :      is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
    2629                 :            :      - if the actual argument is (a substring of) an element of a
    2630                 :            :        non-assumed-shape/non-pointer/non-polymorphic array; or
    2631                 :            :      - (F2003) if the actual argument is of type character of default/c_char
    2632                 :            :        kind.  */
    2633                 :            : 
    2634                 :       1218 :   is_pointer = actual->expr_type == EXPR_VARIABLE
    2635                 :        609 :                ? actual->symtree->n.sym->attr.pointer : false;
    2636                 :            : 
    2637                 :        637 :   for (ref = actual->ref; ref; ref = ref->next)
    2638                 :            :     {
    2639                 :        444 :       if (ref->type == REF_COMPONENT)
    2640                 :         12 :         is_pointer = ref->u.c.component->attr.pointer;
    2641                 :        432 :       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
    2642                 :        420 :                && ref->u.ar.dimen > 0
    2643                 :        417 :                && (!ref->next
    2644                 :          9 :                    || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
    2645                 :            :         break;
    2646                 :            :     }
    2647                 :            : 
    2648                 :        609 :   if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
    2649                 :            :     {
    2650                 :          0 :       if (where)
    2651                 :          0 :         gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
    2652                 :            :                    "at %L", formal->name, &actual->where);
    2653                 :          0 :       return false;
    2654                 :            :     }
    2655                 :            : 
    2656                 :        609 :   if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
    2657                 :        367 :       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
    2658                 :            :     {
    2659                 :         10 :       if (where)
    2660                 :            :         {
    2661                 :         10 :           if (formal->attr.artificial)
    2662                 :          3 :             gfc_error ("Element of assumed-shape or pointer array "
    2663                 :            :                        "as actual argument at %L cannot correspond to "
    2664                 :            :                        "actual argument at %L",
    2665                 :            :                        &actual->where, &formal->declared_at);
    2666                 :            :           else
    2667                 :          7 :             gfc_error ("Element of assumed-shape or pointer "
    2668                 :            :                        "array passed to array dummy argument %qs at %L",
    2669                 :            :                        formal->name, &actual->where);
    2670                 :            :         }
    2671                 :         10 :       return false;
    2672                 :            :     }
    2673                 :            : 
    2674                 :        599 :   if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
    2675                 :        188 :       && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
    2676                 :            :     {
    2677                 :        171 :       if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
    2678                 :            :         {
    2679                 :          0 :           if (where)
    2680                 :          0 :             gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
    2681                 :            :                        "CHARACTER actual argument with array dummy argument "
    2682                 :            :                        "%qs at %L", formal->name, &actual->where);
    2683                 :          0 :           return false;
    2684                 :            :         }
    2685                 :            : 
    2686                 :        171 :       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
    2687                 :            :         {
    2688                 :         50 :           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
    2689                 :            :                      "array dummy argument %qs at %L",
    2690                 :            :                      formal->name, &actual->where);
    2691                 :         50 :           return false;
    2692                 :            :         }
    2693                 :            :       else
    2694                 :        121 :         return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
    2695                 :            :     }
    2696                 :            : 
    2697                 :        428 :   if (ref == NULL && actual->expr_type != EXPR_NULL)
    2698                 :            :     {
    2699                 :         36 :       if (where 
    2700                 :         36 :           && (!formal->attr.artificial || (!formal->maybe_array
    2701                 :          3 :                                            && !maybe_dummy_array_arg (actual))))
    2702                 :            :         {
    2703                 :         35 :           locus *where_formal;
    2704                 :         35 :           if (formal->attr.artificial)
    2705                 :          2 :             where_formal = &formal->declared_at;
    2706                 :            :           else
    2707                 :            :             where_formal = NULL;
    2708                 :            : 
    2709                 :         70 :           argument_rank_mismatch (formal->name, &actual->where,
    2710                 :            :                                   symbol_rank (formal), actual->rank,
    2711                 :            :                                   where_formal);
    2712                 :            :         }
    2713                 :         36 :       return false;
    2714                 :            :     }
    2715                 :            : 
    2716                 :            :   return true;
    2717                 :            : }
    2718                 :            : 
    2719                 :            : 
    2720                 :            : /* Returns the storage size of a symbol (formal argument) or
    2721                 :            :    zero if it cannot be determined.  */
    2722                 :            : 
    2723                 :            : static unsigned long
    2724                 :     141960 : get_sym_storage_size (gfc_symbol *sym)
    2725                 :            : {
    2726                 :     141960 :   int i;
    2727                 :     141960 :   unsigned long strlen, elements;
    2728                 :            : 
    2729                 :     141960 :   if (sym->ts.type == BT_CHARACTER)
    2730                 :            :     {
    2731                 :      18121 :       if (sym->ts.u.cl && sym->ts.u.cl->length
    2732                 :       3662 :           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    2733                 :       3270 :         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
    2734                 :            :       else
    2735                 :            :         return 0;
    2736                 :            :     }
    2737                 :            :   else
    2738                 :            :     strlen = 1;
    2739                 :            : 
    2740                 :     144466 :   if (symbol_rank (sym) == 0)
    2741                 :            :     return strlen;
    2742                 :            : 
    2743                 :      17311 :   elements = 1;
    2744                 :      17311 :   if (sym->as->type != AS_EXPLICIT)
    2745                 :            :     return 0;
    2746                 :      12147 :   for (i = 0; i < sym->as->rank; i++)
    2747                 :            :     {
    2748                 :       8013 :       if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
    2749                 :       5357 :           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
    2750                 :            :         return 0;
    2751                 :            : 
    2752                 :       5357 :       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
    2753                 :       5357 :                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
    2754                 :            :     }
    2755                 :            : 
    2756                 :       4134 :   return strlen*elements;
    2757                 :            : }
    2758                 :            : 
    2759                 :            : 
    2760                 :            : /* Returns the storage size of an expression (actual argument) or
    2761                 :            :    zero if it cannot be determined. For an array element, it returns
    2762                 :            :    the remaining size as the element sequence consists of all storage
    2763                 :            :    units of the actual argument up to the end of the array.  */
    2764                 :            : 
    2765                 :            : static unsigned long
    2766                 :     141960 : get_expr_storage_size (gfc_expr *e)
    2767                 :            : {
    2768                 :     141960 :   int i;
    2769                 :     141960 :   long int strlen, elements;
    2770                 :     141960 :   long int substrlen = 0;
    2771                 :     141960 :   bool is_str_storage = false;
    2772                 :     141960 :   gfc_ref *ref;
    2773                 :            : 
    2774                 :     141960 :   if (e == NULL)
    2775                 :            :     return 0;
    2776                 :            : 
    2777                 :     141960 :   if (e->ts.type == BT_CHARACTER)
    2778                 :            :     {
    2779                 :      18178 :       if (e->ts.u.cl && e->ts.u.cl->length
    2780                 :       5377 :           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    2781                 :       4644 :         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
    2782                 :      13534 :       else if (e->expr_type == EXPR_CONSTANT
    2783                 :      11447 :                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
    2784                 :      11447 :         strlen = e->value.character.length;
    2785                 :            :       else
    2786                 :            :         return 0;
    2787                 :            :     }
    2788                 :            :   else
    2789                 :            :     strlen = 1; /* Length per element.  */
    2790                 :            : 
    2791                 :     139873 :   if (e->rank == 0 && !e->ref)
    2792                 :     115732 :     return strlen;
    2793                 :            : 
    2794                 :      24141 :   elements = 1;
    2795                 :      24141 :   if (!e->ref)
    2796                 :            :     {
    2797                 :       3464 :       if (!e->shape)
    2798                 :            :         return 0;
    2799                 :       6330 :       for (i = 0; i < e->rank; i++)
    2800                 :       3581 :         elements *= mpz_get_si (e->shape[i]);
    2801                 :       2749 :       return elements*strlen;
    2802                 :            :     }
    2803                 :            : 
    2804                 :      32858 :   for (ref = e->ref; ref; ref = ref->next)
    2805                 :            :     {
    2806                 :      21529 :       if (ref->type == REF_SUBSTRING && ref->u.ss.start
    2807                 :         58 :           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
    2808                 :            :         {
    2809                 :         52 :           if (is_str_storage)
    2810                 :            :             {
    2811                 :            :               /* The string length is the substring length.
    2812                 :            :                  Set now to full string length.  */
    2813                 :          5 :               if (!ref->u.ss.length || !ref->u.ss.length->length
    2814                 :          4 :                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
    2815                 :            :                 return 0;
    2816                 :            : 
    2817                 :          4 :               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
    2818                 :            :             }
    2819                 :         51 :           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
    2820                 :         51 :           continue;
    2821                 :            :         }
    2822                 :            : 
    2823                 :      21477 :       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
    2824                 :       2840 :         for (i = 0; i < ref->u.ar.dimen; i++)
    2825                 :            :           {
    2826                 :       1944 :             long int start, end, stride;
    2827                 :       1944 :             stride = 1;
    2828                 :            : 
    2829                 :       1944 :             if (ref->u.ar.stride[i])
    2830                 :            :               {
    2831                 :        485 :                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
    2832                 :        484 :                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
    2833                 :            :                 else
    2834                 :            :                   return 0;
    2835                 :            :               }
    2836                 :            : 
    2837                 :       1943 :             if (ref->u.ar.start[i])
    2838                 :            :               {
    2839                 :       1332 :                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
    2840                 :       1117 :                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
    2841                 :            :                 else
    2842                 :            :                   return 0;
    2843                 :            :               }
    2844                 :        611 :             else if (ref->u.ar.as->lower[i]
    2845                 :        461 :                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
    2846                 :        461 :               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
    2847                 :            :             else
    2848                 :            :               return 0;
    2849                 :            : 
    2850                 :       1578 :             if (ref->u.ar.end[i])
    2851                 :            :               {
    2852                 :        935 :                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
    2853                 :        816 :                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
    2854                 :            :                 else
    2855                 :            :                   return 0;
    2856                 :            :               }
    2857                 :        643 :             else if (ref->u.ar.as->upper[i]
    2858                 :        605 :                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
    2859                 :        571 :               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
    2860                 :            :             else
    2861                 :            :               return 0;
    2862                 :            : 
    2863                 :       1387 :             elements *= (end - start)/stride + 1L;
    2864                 :            :           }
    2865                 :      20024 :       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
    2866                 :      25720 :         for (i = 0; i < ref->u.ar.as->rank; i++)
    2867                 :            :           {
    2868                 :      17354 :             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
    2869                 :      12429 :                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
    2870                 :      12428 :                 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
    2871                 :      12428 :                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
    2872                 :      10854 :                 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
    2873                 :      10854 :               elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
    2874                 :      10854 :                           - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
    2875                 :      10854 :                           + 1L;
    2876                 :            :             else
    2877                 :            :               return 0;
    2878                 :            :           }
    2879                 :       5158 :       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
    2880                 :       3758 :                && e->expr_type == EXPR_VARIABLE)
    2881                 :            :         {
    2882                 :       3758 :           if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
    2883                 :       3625 :               || e->symtree->n.sym->attr.pointer)
    2884                 :            :             {
    2885                 :        173 :               elements = 1;
    2886                 :        173 :               continue;
    2887                 :            :             }
    2888                 :            : 
    2889                 :            :           /* Determine the number of remaining elements in the element
    2890                 :            :              sequence for array element designators.  */
    2891                 :       3585 :           is_str_storage = true;
    2892                 :       5003 :           for (i = ref->u.ar.dimen - 1; i >= 0; i--)
    2893                 :            :             {
    2894                 :       3707 :               if (ref->u.ar.start[i] == NULL
    2895                 :       3707 :                   || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
    2896                 :       2001 :                   || ref->u.ar.as->upper[i] == NULL
    2897                 :       1433 :                   || ref->u.ar.as->lower[i] == NULL
    2898                 :       1433 :                   || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
    2899                 :       1418 :                   || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
    2900                 :            :                 return 0;
    2901                 :            : 
    2902                 :       1418 :               elements
    2903                 :       1418 :                    = elements
    2904                 :       1418 :                      * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
    2905                 :       1418 :                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
    2906                 :       1418 :                         + 1L)
    2907                 :       1418 :                      - (mpz_get_si (ref->u.ar.start[i]->value.integer)
    2908                 :       1418 :                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
    2909                 :            :             }
    2910                 :            :         }
    2911                 :       1400 :       else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
    2912                 :            :                && ref->u.c.component->attr.proc_pointer
    2913                 :       1392 :                && ref->u.c.component->attr.dimension)
    2914                 :            :         {
    2915                 :            :           /* Array-valued procedure-pointer components.  */
    2916                 :          8 :           gfc_array_spec *as = ref->u.c.component->as;
    2917                 :         15 :           for (i = 0; i < as->rank; i++)
    2918                 :            :             {
    2919                 :          8 :               if (!as->upper[i] || !as->lower[i]
    2920                 :          8 :                   || as->upper[i]->expr_type != EXPR_CONSTANT
    2921                 :          7 :                   || as->lower[i]->expr_type != EXPR_CONSTANT)
    2922                 :            :                 return 0;
    2923                 :            : 
    2924                 :          7 :               elements = elements
    2925                 :          7 :                          * (mpz_get_si (as->upper[i]->value.integer)
    2926                 :          7 :                             - mpz_get_si (as->lower[i]->value.integer) + 1L);
    2927                 :            :             }
    2928                 :            :         }
    2929                 :            :     }
    2930                 :            : 
    2931                 :      11329 :   if (substrlen)
    2932                 :         51 :     return (is_str_storage) ? substrlen + (elements-1)*strlen
    2933                 :         51 :                             : elements*strlen;
    2934                 :            :   else
    2935                 :      11278 :     return elements*strlen;
    2936                 :            : }
    2937                 :            : 
    2938                 :            : 
    2939                 :            : /* Given an expression, check whether it is an array section
    2940                 :            :    which has a vector subscript.  */
    2941                 :            : 
    2942                 :            : bool
    2943                 :      10799 : gfc_has_vector_subscript (gfc_expr *e)
    2944                 :            : {
    2945                 :      10799 :   int i;
    2946                 :      10799 :   gfc_ref *ref;
    2947                 :            : 
    2948                 :      10799 :   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
    2949                 :            :     return false;
    2950                 :            : 
    2951                 :      10367 :   for (ref = e->ref; ref; ref = ref->next)
    2952                 :       6153 :     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
    2953                 :       1778 :       for (i = 0; i < ref->u.ar.dimen; i++)
    2954                 :       1080 :         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
    2955                 :            :           return true;
    2956                 :            : 
    2957                 :            :   return false;
    2958                 :            : }
    2959                 :            : 
    2960                 :            : 
    2961                 :            : static bool
    2962                 :         27 : is_procptr_result (gfc_expr *expr)
    2963                 :            : {
    2964                 :         27 :   gfc_component *c = gfc_get_proc_ptr_comp (expr);
    2965                 :         27 :   if (c)
    2966                 :          2 :     return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
    2967                 :            :   else
    2968                 :         26 :     return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
    2969                 :         28 :             && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
    2970                 :            : }
    2971                 :            : 
    2972                 :            : 
    2973                 :            : /* Recursively append candidate argument ARG to CANDIDATES.  Store the
    2974                 :            :    number of total candidates in CANDIDATES_LEN.  */
    2975                 :            : 
    2976                 :            : static void
    2977                 :          1 : lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
    2978                 :            :                                   char **&candidates,
    2979                 :            :                                   size_t &candidates_len)
    2980                 :            : {
    2981                 :          2 :   for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
    2982                 :          1 :     vec_push (candidates, candidates_len, p->sym->name);
    2983                 :          0 : }
    2984                 :            : 
    2985                 :            : 
    2986                 :            : /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account.  */
    2987                 :            : 
    2988                 :            : static const char*
    2989                 :          1 : lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
    2990                 :            : {
    2991                 :          1 :   char **candidates = NULL;
    2992                 :          1 :   size_t candidates_len = 0;
    2993                 :          1 :   lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
    2994                 :          1 :   return gfc_closest_fuzzy_match (arg, candidates);
    2995                 :            : }
    2996                 :            : 
    2997                 :            : 
    2998                 :            : /* Given formal and actual argument lists, see if they are compatible.
    2999                 :            :    If they are compatible, the actual argument list is sorted to
    3000                 :            :    correspond with the formal list, and elements for missing optional
    3001                 :            :    arguments are inserted. If WHERE pointer is nonnull, then we issue
    3002                 :            :    errors when things don't match instead of just returning the status
    3003                 :            :    code.  */
    3004                 :            : 
    3005                 :            : bool
    3006                 :     113628 : gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
    3007                 :            :                            int ranks_must_agree, int is_elemental,
    3008                 :            :                            bool in_statement_function, locus *where)
    3009                 :            : {
    3010                 :     113628 :   gfc_actual_arglist **new_arg, *a, *actual;
    3011                 :     113628 :   gfc_formal_arglist *f;
    3012                 :     113628 :   int i, n, na;
    3013                 :     113628 :   unsigned long actual_size, formal_size;
    3014                 :     113628 :   bool full_array = false;
    3015                 :     113628 :   gfc_array_ref *actual_arr_ref;
    3016                 :            : 
    3017                 :     113628 :   actual = *ap;
    3018                 :            : 
    3019                 :     113628 :   if (actual == NULL && formal == NULL)
    3020                 :            :     return true;
    3021                 :            : 
    3022                 :            :   n = 0;
    3023                 :     318168 :   for (f = formal; f; f = f->next)
    3024                 :     214472 :     n++;
    3025                 :            : 
    3026                 :     103696 :   new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
    3027                 :            : 
    3028                 :     318168 :   for (i = 0; i < n; i++)
    3029                 :     214472 :     new_arg[i] = NULL;
    3030                 :            : 
    3031                 :            :   na = 0;
    3032                 :            :   f = formal;
    3033                 :            :   i = 0;
    3034                 :            : 
    3035                 :     254488 :   for (a = actual; a; a = a->next, f = f->next)
    3036                 :            :     {
    3037                 :     187741 :       if (a->name != NULL && in_statement_function)
    3038                 :            :         {
    3039                 :          1 :           gfc_error ("Keyword argument %qs at %L is invalid in "
    3040                 :          1 :                      "a statement function", a->name, &a->expr->where);
    3041                 :          1 :           return false;
    3042                 :            :         }
    3043                 :            : 
    3044                 :            :       /* Look for keywords but ignore g77 extensions like %VAL.  */
    3045                 :     187740 :       if (a->name != NULL && a->name[0] != '%')
    3046                 :            :         {
    3047                 :            :           i = 0;
    3048                 :       4277 :           for (f = formal; f; f = f->next, i++)
    3049                 :            :             {
    3050                 :       4273 :               if (f->sym == NULL)
    3051                 :          0 :                 continue;
    3052                 :       4273 :               if (strcmp (f->sym->name, a->name) == 0)
    3053                 :            :                 break;
    3054                 :            :             }
    3055                 :            : 
    3056                 :       1684 :           if (f == NULL)
    3057                 :            :             {
    3058                 :          4 :               if (where)
    3059                 :            :                 {
    3060                 :          1 :                   const char *guessed = lookup_arg_fuzzy (a->name, formal);
    3061                 :          1 :                   if (guessed)
    3062                 :          1 :                     gfc_error ("Keyword argument %qs at %L is not in "
    3063                 :            :                                "the procedure; did you mean %qs?",
    3064                 :          1 :                                a->name, &a->expr->where, guessed);
    3065                 :            :                   else
    3066                 :          0 :                     gfc_error ("Keyword argument %qs at %L is not in "
    3067                 :          0 :                                "the procedure", a->name, &a->expr->where);
    3068                 :            :                 }
    3069                 :          4 :               return false;
    3070                 :            :             }
    3071                 :            : 
    3072                 :       1680 :           if (new_arg[i] != NULL)
    3073                 :            :             {
    3074                 :          0 :               if (where)
    3075                 :          0 :                 gfc_error ("Keyword argument %qs at %L is already associated "
    3076                 :            :                            "with another actual argument", a->name,
    3077                 :          0 :                            &a->expr->where);
    3078                 :          0 :               return false;
    3079                 :            :             }
    3080                 :            :         }
    3081                 :            : 
    3082                 :     187736 :       if (f == NULL)
    3083                 :            :         {
    3084                 :        907 :           if (where)
    3085                 :          4 :             gfc_error ("More actual than formal arguments in procedure "
    3086                 :            :                        "call at %L", where);
    3087                 :            : 
    3088                 :        907 :           return false;
    3089                 :            :         }
    3090                 :            : 
    3091                 :     186829 :       if (f->sym == NULL && a->expr == NULL)
    3092                 :        210 :         goto match;
    3093                 :            : 
    3094                 :     186619 :       if (f->sym == NULL)
    3095                 :            :         {
    3096                 :            :           /* These errors have to be issued, otherwise an ICE can occur.
    3097                 :            :              See PR 78865.  */
    3098                 :          2 :           if (where)
    3099                 :          2 :             gfc_error_now ("Missing alternate return specifier in subroutine "
    3100                 :            :                            "call at %L", where);
    3101                 :          2 :           return false;
    3102                 :            :         }
    3103                 :            : 
    3104                 :     186617 :       if (a->expr == NULL)
    3105                 :            :         {
    3106                 :          2 :           if (f->sym->attr.optional)
    3107                 :          0 :             continue;
    3108                 :            :           else
    3109                 :            :             {
    3110                 :          2 :               if (where)
    3111                 :          1 :                 gfc_error_now ("Unexpected alternate return specifier in "
    3112                 :            :                                "subroutine call at %L", where);
    3113                 :          2 :               return false;
    3114                 :            :             }
    3115                 :            :         }
    3116                 :            : 
    3117                 :            :       /* Make sure that intrinsic vtables exist for calls to unlimited
    3118                 :            :          polymorphic formal arguments.  */
    3119                 :     186615 :       if (UNLIMITED_POLY (f->sym)
    3120                 :        797 :           && a->expr->ts.type != BT_DERIVED
    3121                 :        778 :           && a->expr->ts.type != BT_CLASS
    3122                 :        417 :           && a->expr->ts.type != BT_ASSUMED)
    3123                 :        414 :         gfc_find_vtab (&a->expr->ts);
    3124                 :            : 
    3125                 :     186615 :       if (a->expr->expr_type == EXPR_NULL
    3126                 :        244 :           && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
    3127                 :         80 :                && (f->sym->attr.allocatable || !f->sym->attr.optional
    3128                 :         77 :                    || (gfc_option.allow_std & GFC_STD_F2008) == 0))
    3129                 :        239 :               || (f->sym->ts.type == BT_CLASS
    3130                 :         12 :                   && !CLASS_DATA (f->sym)->attr.class_pointer
    3131                 :          6 :                   && (CLASS_DATA (f->sym)->attr.allocatable
    3132                 :          6 :                       || !f->sym->attr.optional
    3133                 :          6 :                       || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
    3134                 :            :         {
    3135                 :          5 :           if (where
    3136                 :          3 :               && (!f->sym->attr.optional
    3137                 :          2 :                   || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
    3138                 :          1 :                   || (f->sym->ts.type == BT_CLASS
    3139                 :          0 :                          && CLASS_DATA (f->sym)->attr.allocatable)))
    3140                 :          2 :             gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
    3141                 :            :                        where, f->sym->name);
    3142                 :          3 :           else if (where)
    3143                 :          1 :             gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
    3144                 :            :                        "dummy %qs", where, f->sym->name);
    3145                 :            : 
    3146                 :          5 :           return false;
    3147                 :            :         }
    3148                 :            : 
    3149                 :     186610 :       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
    3150                 :            :                               is_elemental, where))
    3151                 :            :         return false;
    3152                 :            : 
    3153                 :            :       /* TS 29113, 6.3p2.  */
    3154                 :     150730 :       if (f->sym->ts.type == BT_ASSUMED
    3155                 :       1885 :           && (a->expr->ts.type == BT_DERIVED
    3156                 :       1697 :               || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
    3157                 :            :         {
    3158                 :        260 :           gfc_namespace *f2k_derived;
    3159                 :            : 
    3160                 :        520 :           f2k_derived = a->expr->ts.type == BT_DERIVED
    3161                 :        260 :                         ? a->expr->ts.u.derived->f2k_derived
    3162                 :         72 :                         : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
    3163                 :            : 
    3164                 :        260 :           if (f2k_derived
    3165                 :        258 :               && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
    3166                 :            :             {
    3167                 :          2 :               gfc_error ("Actual argument at %L to assumed-type dummy is of "
    3168                 :            :                          "derived type with type-bound or FINAL procedures",
    3169                 :            :                          &a->expr->where);
    3170                 :          2 :               return false;
    3171                 :            :             }
    3172                 :            :         }
    3173                 :            : 
    3174                 :            :       /* Special case for character arguments.  For allocatable, pointer
    3175                 :            :          and assumed-shape dummies, the string length needs to match
    3176                 :            :          exactly.  */
    3177                 :     150728 :       if (a->expr->ts.type == BT_CHARACTER
    3178                 :      18277 :           && a->expr->ts.u.cl && a->expr->ts.u.cl->length
    3179                 :       5433 :           && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
    3180                 :       4700 :           && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl
    3181                 :       4575 :           && f->sym->ts.u.cl->length
    3182                 :       2629 :           && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
    3183                 :       2371 :           && (f->sym->attr.pointer || f->sym->attr.allocatable
    3184                 :       2285 :               || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
    3185                 :        273 :           && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
    3186                 :        273 :                        f->sym->ts.u.cl->length->value.integer) != 0))
    3187                 :            :         {
    3188                 :          6 :           if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
    3189                 :          5 :             gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
    3190                 :            :                          "argument and pointer or allocatable dummy argument "
    3191                 :            :                          "%qs at %L",
    3192                 :            :                          mpz_get_si (a->expr->ts.u.cl->length->value.integer),
    3193                 :            :                          mpz_get_si (f->sym->ts.u.cl->length->value.integer),
    3194                 :            :                          f->sym->name, &a->expr->where);
    3195                 :          1 :           else if (where)
    3196                 :          1 :             gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
    3197                 :            :                          "argument and assumed-shape dummy argument %qs "
    3198                 :            :                          "at %L",
    3199                 :            :                          mpz_get_si (a->expr->ts.u.cl->length->value.integer),
    3200                 :            :                          mpz_get_si (f->sym->ts.u.cl->length->value.integer),
    3201                 :            :                          f->sym->name, &a->expr->where);
    3202                 :          6 :           return false;
    3203                 :            :         }
    3204                 :            : 
    3205                 :     150722 :       if ((f->sym->attr.pointer || f->sym->attr.allocatable)
    3206                 :       4050 :           && f->sym->ts.deferred != a->expr->ts.deferred
    3207                 :          1 :           && a->expr->ts.type == BT_CHARACTER)
    3208                 :            :         {
    3209                 :          1 :           if (where)
    3210                 :          1 :             gfc_error ("Actual argument at %L to allocatable or "
    3211                 :            :                        "pointer dummy argument %qs must have a deferred "
    3212                 :            :                        "length type parameter if and only if the dummy has one",
    3213                 :            :                        &a->expr->where, f->sym->name);
    3214                 :          1 :           return false;
    3215                 :            :         }
    3216                 :            : 
    3217                 :     150721 :       if (f->sym->ts.type == BT_CLASS)
    3218                 :       8761 :         goto skip_size_check;
    3219                 :            : 
    3220                 :     141960 :       actual_size = get_expr_storage_size (a->expr);
    3221                 :     141960 :       formal_size = get_sym_storage_size (f->sym);
    3222                 :     141960 :       if (actual_size != 0 && actual_size < formal_size
    3223                 :         75 :           && a->expr->ts.type != BT_PROCEDURE
    3224                 :         69 :           && f->sym->attr.flavor != FL_PROCEDURE)
    3225                 :            :         {
    3226                 :         69 :           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
    3227                 :         28 :             gfc_warning (0, "Character length of actual argument shorter "
    3228                 :            :                          "than of dummy argument %qs (%lu/%lu) at %L",
    3229                 :            :                          f->sym->name, actual_size, formal_size,
    3230                 :            :                          &a->expr->where);
    3231                 :         41 :           else if (where)
    3232                 :            :             {
    3233                 :            :               /* Emit a warning for -std=legacy and an error otherwise. */
    3234                 :         41 :               if (gfc_option.warn_std == 0)
    3235                 :          0 :                 gfc_warning (0, "Actual argument contains too few "
    3236                 :            :                              "elements for dummy argument %qs (%lu/%lu) "
    3237                 :            :                              "at %L", f->sym->name, actual_size,
    3238                 :            :                              formal_size, &a->expr->where);
    3239                 :            :               else
    3240                 :         41 :                 gfc_error_now ("Actual argument contains too few "
    3241                 :            :                                "elements for dummy argument %qs (%lu/%lu) "
    3242                 :            :                                "at %L", f->sym->name, actual_size,
    3243                 :            :                                formal_size, &a->expr->where);
    3244                 :            :             }
    3245                 :         69 :           return false;
    3246                 :            :         }
    3247                 :            : 
    3248                 :     141891 :      skip_size_check:
    3249                 :            : 
    3250                 :            :       /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
    3251                 :            :          argument is provided for a procedure pointer formal argument.  */
    3252                 :     150652 :       if (f->sym->attr.proc_pointer
    3253                 :        135 :           && !((a->expr->expr_type == EXPR_VARIABLE
    3254                 :        129 :                 && (a->expr->symtree->n.sym->attr.proc_pointer
    3255                 :        129 :                     || gfc_is_proc_ptr_comp (a->expr)))
    3256                 :          6 :                || (a->expr->expr_type == EXPR_FUNCTION
    3257                 :     150658 :                    && is_procptr_result (a->expr))))
    3258                 :            :         {
    3259                 :          0 :           if (where)
    3260                 :          0 :             gfc_error ("Expected a procedure pointer for argument %qs at %L",
    3261                 :          0 :                        f->sym->name, &a->expr->where);
    3262                 :          0 :           return false;
    3263                 :            :         }
    3264                 :            : 
    3265                 :            :       /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
    3266                 :            :          provided for a procedure formal argument.  */
    3267                 :     150652 :       if (f->sym->attr.flavor == FL_PROCEDURE
    3268                 :     150652 :           && !((a->expr->expr_type == EXPR_VARIABLE
    3269                 :       1790 :                 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
    3270                 :         31 :                     || a->expr->symtree->n.sym->attr.proc_pointer
    3271                 :         31 :                     || gfc_is_proc_ptr_comp (a->expr)))
    3272                 :         30 :                || (a->expr->expr_type == EXPR_FUNCTION
    3273                 :         21 :                    && is_procptr_result (a->expr))))
    3274                 :            :         {
    3275                 :         12 :           if (where)
    3276                 :          6 :             gfc_error ("Expected a procedure for argument %qs at %L",
    3277                 :          6 :                        f->sym->name, &a->expr->where);
    3278                 :         12 :           return false;
    3279                 :            :         }
    3280                 :            : 
    3281                 :     150640 :       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
    3282                 :       5297 :           && a->expr->expr_type == EXPR_VARIABLE
    3283                 :       3564 :           && a->expr->symtree->n.sym->as
    3284                 :       3498 :           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
    3285                 :          7 :           && (a->expr->ref == NULL
    3286                 :          7 :               || (a->expr->ref->type == REF_ARRAY
    3287                 :          7 :                   && a->expr->ref->u.ar.type == AR_FULL)))
    3288                 :            :         {
    3289                 :          3 :           if (where)
    3290                 :          3 :             gfc_error ("Actual argument for %qs cannot be an assumed-size"
    3291                 :            :                        " array at %L", f->sym->name, where);
    3292                 :          3 :           return false;
    3293                 :            :         }
    3294                 :            : 
    3295                 :     150637 :       if (a->expr->expr_type != EXPR_NULL
    3296                 :     150637 :           && compare_pointer (f->sym, a->expr) == 0)
    3297                 :            :         {
    3298                 :         10 :           if (where)
    3299                 :          4 :             gfc_error ("Actual argument for %qs must be a pointer at %L",
    3300                 :          4 :                        f->sym->name, &a->expr->where);
    3301                 :         10 :           return false;
    3302                 :            :         }
    3303                 :            : 
    3304                 :     150627 :       if (a->expr->expr_type != EXPR_NULL
    3305                 :     150448 :           && (gfc_option.allow_std & GFC_STD_F2008) == 0
    3306                 :     151157 :           && compare_pointer (f->sym, a->expr) == 2)
    3307                 :            :         {
    3308                 :          2 :           if (where)
    3309                 :          2 :             gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
    3310                 :          2 :                        "pointer dummy %qs", &a->expr->where,f->sym->name);
    3311                 :          2 :           return false;
    3312                 :            :         }
    3313                 :            : 
    3314                 :            : 
    3315                 :            :       /* Fortran 2008, C1242.  */
    3316                 :     150625 :       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
    3317                 :            :         {
    3318                 :          2 :           if (where)
    3319                 :          2 :             gfc_error ("Coindexed actual argument at %L to pointer "
    3320                 :            :                        "dummy %qs",
    3321                 :          2 :                        &a->expr->where, f->sym->name);
    3322                 :          2 :           return false;
    3323                 :            :         }
    3324                 :            : 
    3325                 :            :       /* Fortran 2008, 12.5.2.5 (no constraint).  */
    3326                 :     150623 :       if (a->expr->expr_type == EXPR_VARIABLE
    3327                 :      60806 :           && f->sym->attr.intent != INTENT_IN
    3328                 :      38902 :           && f->sym->attr.allocatable
    3329                 :     152066 :           && gfc_is_coindexed (a->expr))
    3330                 :            :         {
    3331                 :          1 :           if (where)
    3332                 :          1 :             gfc_error ("Coindexed actual argument at %L to allocatable "
    3333                 :            :                        "dummy %qs requires INTENT(IN)",
    3334                 :          1 :                        &a->expr->where, f->sym->name);
    3335                 :          1 :           return false;
    3336                 :            :         }
    3337                 :            : 
    3338                 :            :       /* Fortran 2008, C1237.  */
    3339                 :     150622 :       if (a->expr->expr_type == EXPR_VARIABLE
    3340                 :      60805 :           && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
    3341                 :         50 :           && gfc_is_coindexed (a->expr)
    3342                 :     150622 :           && (a->expr->symtree->n.sym->attr.volatile_
    3343                 :          2 :               || a->expr->symtree->n.sym->attr.asynchronous))
    3344                 :            :         {
    3345                 :          2 :           if (where)
    3346                 :          2 :             gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
    3347                 :            :                        "%L requires that dummy %qs has neither "
    3348                 :            :                        "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
    3349                 :          2 :                        f->sym->name);
    3350                 :          2 :           return false;
    3351                 :            :         }
    3352                 :            : 
    3353                 :            :       /* Fortran 2008, 12.5.2.4 (no constraint).  */
    3354                 :     150620 :       if (a->expr->expr_type == EXPR_VARIABLE
    3355                 :      60803 :           && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
    3356                 :      36459 :           && gfc_is_coindexed (a->expr)
    3357                 :     150626 :           && gfc_has_ultimate_allocatable (a->expr))
    3358                 :            :         {
    3359                 :          1 :           if (where)
    3360                 :          1 :             gfc_error ("Coindexed actual argument at %L with allocatable "
    3361                 :            :                        "ultimate component to dummy %qs requires either VALUE "
    3362                 :          1 :                        "or INTENT(IN)", &a->expr->where, f->sym->name);
    3363                 :          1 :           return false;
    3364                 :            :         }
    3365                 :            : 
    3366                 :     150619 :      if (f->sym->ts.type == BT_CLASS
    3367                 :       8760 :            && CLASS_DATA (f->sym)->attr.allocatable
    3368                 :        459 :            && gfc_is_class_array_ref (a->expr, &full_array)
    3369                 :     150815 :            && !full_array)
    3370                 :            :         {
    3371                 :          0 :           if (where)
    3372                 :          0 :             gfc_error ("Actual CLASS array argument for %qs must be a full "
    3373                 :          0 :                        "array at %L", f->sym->name, &a->expr->where);
    3374                 :          0 :           return false;
    3375                 :            :         }
    3376                 :            : 
    3377                 :            : 
    3378                 :     150619 :       if (a->expr->expr_type != EXPR_NULL
    3379                 :     150619 :           && !compare_allocatable (f->sym, a->expr))
    3380                 :            :         {
    3381                 :          6 :           if (where)
    3382                 :          6 :             gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
    3383                 :          6 :                        f->sym->name, &a->expr->where);
    3384                 :          6 :           return false;
    3385                 :            :         }
    3386                 :            : 
    3387                 :            :       /* Check intent = OUT/INOUT for definable actual argument.  */
    3388                 :     150613 :       if (!in_statement_function
    3389                 :     150203 :           && (f->sym->attr.intent == INTENT_OUT
    3390                 :     146863 :               || f->sym->attr.intent == INTENT_INOUT))
    3391                 :            :         {
    3392                 :       6654 :           const char* context = (where
    3393                 :       6654 :                                  ? _("actual argument to INTENT = OUT/INOUT")
    3394                 :       6654 :                                  : NULL);
    3395                 :            : 
    3396                 :       1797 :           if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
    3397                 :       1797 :                 && CLASS_DATA (f->sym)->attr.class_pointer)
    3398                 :       6647 :                || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
    3399                 :       6728 :               && !gfc_check_vardef_context (a->expr, true, false, false, context))
    3400                 :            :             return false;
    3401                 :       6648 :           if (!gfc_check_vardef_context (a->expr, false, false, false, context))
    3402                 :            :             return false;
    3403                 :            :         }
    3404                 :            : 
    3405                 :     150590 :       if ((f->sym->attr.intent == INTENT_OUT
    3406                 :     150590 :            || f->sym->attr.intent == INTENT_INOUT
    3407                 :            :            || f->sym->attr.volatile_
    3408                 :     143957 :            || f->sym->attr.asynchronous)
    3409                 :     150639 :           && gfc_has_vector_subscript (a->expr))
    3410                 :            :         {
    3411                 :          3 :           if (where)
    3412                 :          3 :             gfc_error ("Array-section actual argument with vector "
    3413                 :            :                        "subscripts at %L is incompatible with INTENT(OUT), "
    3414                 :            :                        "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
    3415                 :            :                        "of the dummy argument %qs",
    3416                 :          3 :                        &a->expr->where, f->sym->name);
    3417                 :          3 :           return false;
    3418                 :            :         }
    3419                 :            : 
    3420                 :            :       /* C1232 (R1221) For an actual argument which is an array section or
    3421                 :            :          an assumed-shape array, the dummy argument shall be an assumed-
    3422                 :            :          shape array, if the dummy argument has the VOLATILE attribute.  */
    3423                 :            : 
    3424                 :     150587 :       if (f->sym->attr.volatile_
    3425                 :     150587 :           && a->expr->expr_type == EXPR_VARIABLE
    3426                 :         21 :           && a->expr->symtree->n.sym->as
    3427                 :         18 :           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
    3428                 :          2 :           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
    3429                 :            :         {
    3430                 :          1 :           if (where)
    3431                 :          1 :             gfc_error ("Assumed-shape actual argument at %L is "
    3432                 :            :                        "incompatible with the non-assumed-shape "
    3433                 :            :                        "dummy argument %qs due to VOLATILE attribute",
    3434                 :            :                        &a->expr->where,f->sym->name);
    3435                 :          1 :           return false;
    3436                 :            :         }
    3437                 :            : 
    3438                 :            :       /* Find the last array_ref.  */
    3439                 :     150586 :       actual_arr_ref = NULL;
    3440                 :     150586 :       if (a->expr->ref)
    3441                 :      24650 :         actual_arr_ref = gfc_find_array_ref (a->expr, true);
    3442                 :            : 
    3443                 :     150586 :       if (f->sym->attr.volatile_
    3444                 :     150586 :           && actual_arr_ref && actual_arr_ref->type == AR_SECTION
    3445                 :          4 :           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
    3446                 :            :         {
    3447                 :          1 :           if (where)
    3448                 :          1 :             gfc_error ("Array-section actual argument at %L is "
    3449                 :            :                        "incompatible with the non-assumed-shape "
    3450                 :            :                        "dummy argument %qs due to VOLATILE attribute",
    3451                 :          1 :                        &a->expr->where, f->sym->name);
    3452                 :          1 :           return false;
    3453                 :            :         }
    3454                 :            : 
    3455                 :            :       /* C1233 (R1221) For an actual argument which is a pointer array, the
    3456                 :            :          dummy argument shall be an assumed-shape or pointer array, if the
    3457                 :            :          dummy argument has the VOLATILE attribute.  */
    3458                 :            : 
    3459                 :     150585 :       if (f->sym->attr.volatile_
    3460                 :         22 :           && a->expr->expr_type == EXPR_VARIABLE
    3461                 :         19 :           && a->expr->symtree->n.sym->attr.pointer
    3462                 :         10 :           && a->expr->symtree->n.sym->as
    3463                 :         10 :           && !(f->sym->as
    3464                 :         10 :                && (f->sym->as->type == AS_ASSUMED_SHAPE
    3465                 :          6 :                    || f->sym->attr.pointer)))
    3466                 :            :         {
    3467                 :          3 :           if (where)
    3468                 :          2 :             gfc_error ("Pointer-array actual argument at %L requires "
    3469                 :            :                        "an assumed-shape or pointer-array dummy "
    3470                 :            :                        "argument %qs due to VOLATILE attribute",
    3471                 :            :                        &a->expr->where,f->sym->name);
    3472                 :          3 :           return false;
    3473                 :            :         }
    3474                 :            : 
    3475                 :     150582 :     match:
    3476                 :     150792 :       if (a == actual)
    3477                 :      71567 :         na = i;
    3478                 :            : 
    3479                 :     150792 :       new_arg[i++] = a;
    3480                 :            :     }
    3481                 :            : 
    3482                 :            :   /* Make sure missing actual arguments are optional.  */
    3483                 :            :   i = 0;
    3484                 :     214675 :   for (f = formal; f; f = f->next, i++)
    3485                 :            :     {
    3486                 :     147954 :       if (new_arg[i] != NULL)
    3487                 :     145442 :         continue;
    3488                 :       2512 :       if (f->sym == NULL)
    3489                 :            :         {
    3490                 :          1 :           if (where)
    3491                 :          1 :             gfc_error ("Missing alternate return spec in subroutine call "
    3492                 :            :                        "at %L", where);
    3493                 :          1 :           return false;
    3494                 :            :         }
    3495                 :       2511 :       if (!f->sym->attr.optional
    3496                 :       2487 :           || (in_statement_function && f->sym->attr.optional))
    3497                 :            :         {
    3498                 :         25 :           if (where)
    3499                 :          4 :             gfc_error ("Missing actual argument for argument %qs at %L",
    3500                 :            :                        f->sym->name, where);
    3501                 :         25 :           return false;
    3502                 :            :         }
    3503                 :            :     }
    3504                 :            : 
    3505                 :            :   /* The argument lists are compatible.  We now relink a new actual
    3506                 :            :      argument list with null arguments in the right places.  The head
    3507                 :            :      of the list remains the head.  */
    3508                 :     214638 :   for (i = 0; i < n; i++)
    3509                 :     147917 :     if (new_arg[i] == NULL)
    3510                 :       2486 :       new_arg[i] = gfc_get_actual_arglist ();
    3511                 :            : 
    3512                 :      66721 :   if (na != 0)
    3513                 :            :     {
    3514                 :        209 :       std::swap (*new_arg[0], *actual);
    3515                 :        209 :       std::swap (new_arg[0], new_arg[na]);
    3516                 :            :     }
    3517                 :            : 
    3518                 :     147917 :   for (i = 0; i < n - 1; i++)
    3519                 :      81196 :     new_arg[i]->next = new_arg[i + 1];
    3520                 :            : 
    3521                 :      66721 :   new_arg[i]->next = NULL;
    3522                 :            : 
    3523                 :      66721 :   if (*ap == NULL && n > 0)
    3524                 :        480 :     *ap = new_arg[0];
    3525                 :            : 
    3526                 :            :   /* Note the types of omitted optional arguments.  */
    3527                 :     214638 :   for (a = *ap, f = formal; a; a = a->next, f = f->next)
    3528                 :     147917 :     if (a->expr == NULL && a->label == NULL)
    3529                 :       2486 :       a->missing_arg_type = f->sym->ts.type;
    3530                 :            : 
    3531                 :            :   return true;
    3532                 :            : }
    3533                 :            : 
    3534                 :            : 
    3535                 :            : typedef struct
    3536                 :            : {
    3537                 :            :   gfc_formal_arglist *f;
    3538                 :            :   gfc_actual_arglist *a;
    3539                 :            : }
    3540                 :            : argpair;
    3541                 :            : 
    3542                 :            : /* qsort comparison function for argument pairs, with the following
    3543                 :            :    order:
    3544                 :            :     - p->a->expr == NULL
    3545                 :            :     - p->a->expr->expr_type != EXPR_VARIABLE
    3546                 :            :     - by gfc_symbol pointer value (larger first).  */
    3547                 :            : 
    3548                 :            : static int
    3549                 :       2377 : pair_cmp (const void *p1, const void *p2)
    3550                 :            : {
    3551                 :       2377 :   const gfc_actual_arglist *a1, *a2;
    3552                 :            : 
    3553                 :            :   /* *p1 and *p2 are elements of the to-be-sorted array.  */
    3554                 :       2377 :   a1 = ((const argpair *) p1)->a;
    3555                 :       2377 :   a2 = ((const argpair *) p2)->a;
    3556                 :       2377 :   if (!a1->expr)
    3557                 :            :     {
    3558                 :         23 :       if (!a2->expr)
    3559                 :            :         return 0;
    3560                 :         23 :       return -1;
    3561                 :            :     }
    3562                 :       2354 :   if (!a2->expr)
    3563                 :            :     return 1;
    3564                 :       2345 :   if (a1->expr->expr_type != EXPR_VARIABLE)
    3565                 :            :     {
    3566                 :       1622 :       if (a2->expr->expr_type != EXPR_VARIABLE)
    3567                 :            :         return 0;
    3568                 :       1088 :       return -1;
    3569                 :            :     }
    3570                 :        723 :   if (a2->expr->expr_type != EXPR_VARIABLE)
    3571                 :            :     return 1;
    3572                 :        155 :   if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym)
    3573                 :            :     return -1;
    3574                 :         60 :   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
    3575                 :            : }
    3576                 :            : 
    3577                 :            : 
    3578                 :            : /* Given two expressions from some actual arguments, test whether they
    3579                 :            :    refer to the same expression. The analysis is conservative.
    3580                 :            :    Returning false will produce no warning.  */
    3581                 :            : 
    3582                 :            : static bool
    3583                 :         33 : compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
    3584                 :            : {
    3585                 :         33 :   const gfc_ref *r1, *r2;
    3586                 :            : 
    3587                 :         33 :   if (!e1 || !e2
    3588                 :         33 :       || e1->expr_type != EXPR_VARIABLE
    3589                 :         33 :       || e2->expr_type != EXPR_VARIABLE
    3590                 :         33 :       || e1->symtree->n.sym != e2->symtree->n.sym)
    3591                 :            :     return false;
    3592                 :            : 
    3593                 :            :   /* TODO: improve comparison, see expr.c:show_ref().  */
    3594                 :          4 :   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
    3595                 :            :     {
    3596                 :          1 :       if (r1->type != r2->type)
    3597                 :            :         return false;
    3598                 :          1 :       switch (r1->type)
    3599                 :            :         {
    3600                 :          0 :         case REF_ARRAY:
    3601                 :          0 :           if (r1->u.ar.type != r2->u.ar.type)
    3602                 :            :             return false;
    3603                 :            :           /* TODO: At the moment, consider only full arrays;
    3604                 :            :              we could do better.  */
    3605                 :          0 :           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
    3606                 :            :             return false;
    3607                 :            :           break;
    3608                 :            : 
    3609                 :          0 :         case REF_COMPONENT:
    3610                 :          0 :           if (r1->u.c.component != r2->u.c.component)
    3611                 :            :             return false;
    3612                 :            :           break;
    3613                 :            : 
    3614                 :            :         case REF_SUBSTRING:
    3615                 :            :           return false;
    3616                 :            : 
    3617                 :          1 :         case REF_INQUIRY:
    3618                 :          1 :           if (e1->symtree->n.sym->ts.type == BT_COMPLEX
    3619                 :          1 :               && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL
    3620                 :          1 :               && r1->u.i != r2->u.i)
    3621                 :            :             return false;
    3622                 :            :           break;
    3623                 :            : 
    3624                 :          0 :         default:
    3625                 :          0 :           gfc_internal_error ("compare_actual_expr(): Bad component code");
    3626                 :            :         }
    3627                 :            :     }
    3628                 :          3 :   if (!r1 && !r2)
    3629                 :          3 :     return true;
    3630                 :            :   return false;
    3631                 :            : }
    3632                 :            : 
    3633                 :            : 
    3634                 :            : /* Given formal and actual argument lists that correspond to one
    3635                 :            :    another, check that identical actual arguments aren't not
    3636                 :            :    associated with some incompatible INTENTs.  */
    3637                 :            : 
    3638                 :            : static bool
    3639                 :        831 : check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
    3640                 :            : {
    3641                 :        831 :   sym_intent f1_intent, f2_intent;
    3642                 :        831 :   gfc_formal_arglist *f1;
    3643                 :        831 :   gfc_actual_arglist *a1;
    3644                 :        831 :   size_t n, i, j;
    3645                 :        831 :   argpair *p;
    3646                 :        831 :   bool t = true;
    3647                 :            : 
    3648                 :        831 :   n = 0;
    3649                 :        831 :   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
    3650                 :            :     {
    3651                 :       2207 :       if (f1 == NULL && a1 == NULL)
    3652                 :            :         break;
    3653                 :       1376 :       if (f1 == NULL || a1 == NULL)
    3654                 :          0 :         gfc_internal_error ("check_some_aliasing(): List mismatch");
    3655                 :       1376 :       n++;
    3656                 :            :     }
    3657                 :        831 :   if (n == 0)
    3658                 :            :     return t;
    3659                 :        800 :   p = XALLOCAVEC (argpair, n);
    3660                 :            : 
    3661                 :       2176 :   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
    3662                 :            :     {
    3663                 :       1376 :       p[i].f = f1;
    3664                 :       1376 :       p[i].a = a1;
    3665                 :            :     }
    3666                 :            : 
    3667                 :        800 :   qsort (p, n, sizeof (argpair), pair_cmp);
    3668                 :            : 
    3669                 :       2176 :   for (i = 0; i < n; i++)
    3670                 :            :     {
    3671                 :       1376 :       if (!p[i].a->expr
    3672                 :       1371 :           || p[i].a->expr->expr_type != EXPR_VARIABLE
    3673                 :        545 :           || p[i].a->expr->ts.type == BT_PROCEDURE)
    3674                 :        832 :         continue;
    3675                 :        544 :       f1_intent = p[i].f->sym->attr.intent;
    3676                 :        547 :       for (j = i + 1; j < n; j++)
    3677                 :            :         {
    3678                 :            :           /* Expected order after the sort.  */
    3679                 :         33 :           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
    3680                 :          0 :             gfc_internal_error ("check_some_aliasing(): corrupted data");
    3681                 :            : 
    3682                 :            :           /* Are the expression the same?  */
    3683                 :         33 :           if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
    3684                 :            :             break;
    3685                 :          3 :           f2_intent = p[j].f->sym->attr.intent;
    3686                 :          3 :           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
    3687                 :          2 :               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
    3688                 :          1 :               || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
    3689                 :            :             {
    3690                 :          3 :               gfc_warning (0, "Same actual argument associated with INTENT(%s) "
    3691                 :            :                            "argument %qs and INTENT(%s) argument %qs at %L",
    3692                 :          3 :                            gfc_intent_string (f1_intent), p[i].f->sym->name,
    3693                 :            :                            gfc_intent_string (f2_intent), p[j].f->sym->name,
    3694                 :            :                            &p[i].a->expr->where);
    3695                 :          3 :               t = false;
    3696                 :            :             }
    3697                 :            :         }
    3698                 :            :     }
    3699                 :            : 
    3700                 :            :   return t;
    3701                 :            : }
    3702                 :            : 
    3703                 :            : 
    3704                 :            : /* Given formal and actual argument lists that correspond to one
    3705                 :            :    another, check that they are compatible in the sense that intents
    3706                 :            :    are not mismatched.  */
    3707                 :            : 
    3708                 :            : static bool
    3709                 :      62825 : check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
    3710                 :            : {
    3711                 :     183255 :   sym_intent f_intent;
    3712                 :            : 
    3713                 :     303685 :   for (;; f = f->next, a = a->next)
    3714                 :            :     {
    3715                 :     183255 :       gfc_expr *expr;
    3716                 :            : 
    3717                 :     183255 :       if (f == NULL && a == NULL)
    3718                 :            :         break;
    3719                 :     120434 :       if (f == NULL || a == NULL)
    3720                 :          0 :         gfc_internal_error ("check_intents(): List mismatch");
    3721                 :            : 
    3722                 :     120434 :       if (a->expr && a->expr->expr_type == EXPR_FUNCTION
    3723                 :      10333 :           && a->expr->value.function.isym
    3724                 :       6483 :           && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
    3725                 :          4 :         expr = a->expr->value.function.actual->expr;
    3726                 :            :       else
    3727                 :            :         expr = a->expr;
    3728                 :            : 
    3729                 :     120434 :       if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
    3730                 :      74307 :         continue;
    3731                 :            : 
    3732                 :      46127 :       f_intent = f->sym->attr.intent;
    3733                 :            : 
    3734                 :      46127 :       if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
    3735                 :            :         {
    3736                 :        248 :           if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
    3737                 :         10 :                && CLASS_DATA (f->sym)->attr.class_pointer)
    3738                 :        247 :               || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
    3739                 :            :             {
    3740                 :          2 :               gfc_error ("Procedure argument at %L is local to a PURE "
    3741                 :            :                          "procedure and has the POINTER attribute",
    3742                 :            :                          &expr->where);
    3743                 :          2 :               return false;
    3744                 :            :             }
    3745                 :            :         }
    3746                 :            : 
    3747                 :            :        /* Fortran 2008, C1283.  */
    3748                 :      46125 :        if (gfc_pure (NULL) && gfc_is_coindexed (expr))
    3749                 :            :         {
    3750                 :          1 :           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
    3751                 :            :             {
    3752                 :          1 :               gfc_error ("Coindexed actual argument at %L in PURE procedure "
    3753                 :            :                          "is passed to an INTENT(%s) argument",
    3754                 :            :                          &expr->where, gfc_intent_string (f_intent));
    3755                 :          1 :               return false;
    3756                 :            :             }
    3757                 :            : 
    3758                 :          0 :           if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
    3759                 :          0 :                && CLASS_DATA (f->sym)->attr.class_pointer)
    3760                 :          0 :               || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
    3761                 :            :             {
    3762                 :          0 :               gfc_error ("Coindexed actual argument at %L in PURE procedure "
    3763                 :            :                          "is passed to a POINTER dummy argument",
    3764                 :            :                          &expr->where);
    3765                 :          0 :               return false;
    3766                 :            :             }
    3767                 :            :         }
    3768                 :            : 
    3769                 :            :        /* F2008, Section 12.5.2.4.  */
    3770                 :       4084 :        if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
    3771                 :      49765 :            && gfc_is_coindexed (expr))
    3772                 :            :          {
    3773                 :          1 :            gfc_error ("Coindexed polymorphic actual argument at %L is passed "
    3774                 :            :                       "polymorphic dummy argument %qs",
    3775                 :          1 :                          &expr->where, f->sym->name);
    3776                 :          1 :            return false;
    3777                 :            :          }
    3778                 :     120430 :     }
    3779                 :            : 
    3780                 :            :   return true;
    3781                 :            : }
    3782                 :            : 
    3783                 :            : 
    3784                 :            : /* Check how a procedure is used against its interface.  If all goes
    3785                 :            :    well, the actual argument list will also end up being properly
    3786                 :            :    sorted.  */
    3787                 :            : 
    3788                 :            : bool
    3789                 :      64132 : gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
    3790                 :            : {
    3791                 :      64132 :   gfc_actual_arglist *a;
    3792                 :      64132 :   gfc_formal_arglist *dummy_args;
    3793                 :      64132 :   bool implicit = false;
    3794                 :            : 
    3795                 :            :   /* Warn about calls with an implicit interface.  Special case
    3796                 :            :      for calling a ISO_C_BINDING because c_loc and c_funloc
    3797                 :            :      are pseudo-unknown.  Additionally, warn about procedures not
    3798                 :            :      explicitly declared at all if requested.  */
    3799                 :      64132 :   if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
    3800                 :            :     {
    3801                 :      15597 :       bool has_implicit_none_export = false;
    3802                 :      15597 :       implicit = true;
    3803                 :      15597 :       if (sym->attr.proc == PROC_UNKNOWN)
    3804                 :      22566 :         for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
    3805                 :      11346 :           if (ns->has_implicit_none_export)
    3806                 :            :             {
    3807                 :            :               has_implicit_none_export = true;
    3808                 :            :               break;
    3809                 :            :             }
    3810                 :      11224 :       if (has_implicit_none_export)
    3811                 :            :         {
    3812                 :          4 :           const char *guessed
    3813                 :          4 :             = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
    3814                 :          4 :           if (guessed)
    3815                 :          1 :             gfc_error ("Procedure %qs called at %L is not explicitly declared"
    3816                 :            :                        "; did you mean %qs?",
    3817                 :            :                        sym->name, where, guessed);
    3818                 :            :           else
    3819                 :          3 :             gfc_error ("Procedure %qs called at %L is not explicitly declared",
    3820                 :            :                        sym->name, where);
    3821                 :          4 :           return false;
    3822                 :            :         }
    3823                 :      15593 :       if (warn_implicit_interface)
    3824                 :          0 :         gfc_warning (OPT_Wimplicit_interface,
    3825                 :            :                      "Procedure %qs called with an implicit interface at %L",
    3826                 :            :                      sym->name, where);
    3827                 :      15593 :       else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
    3828                 :          1 :         gfc_warning (OPT_Wimplicit_procedure,
    3829                 :            :                      "Procedure %qs called at %L is not explicitly declared",
    3830                 :            :                      sym->name, where);
    3831                 :      15593 :       gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1;
    3832                 :            :     }
    3833                 :            : 
    3834                 :      64128 :   if (sym->attr.if_source == IFSRC_UNKNOWN)
    3835                 :            :     {
    3836                 :      15593 :       if (sym->attr.pointer)
    3837                 :            :         {
    3838                 :          1 :           gfc_error ("The pointer object %qs at %L must have an explicit "
    3839                 :            :                      "function interface or be declared as array",
    3840                 :            :                      sym->name, where);
    3841                 :          1 :           return false;
    3842                 :            :         }
    3843                 :            : 
    3844                 :      15592 :       if (sym->attr.allocatable && !sym->attr.external)
    3845                 :            :         {
    3846                 :          1 :           gfc_error ("The allocatable object %qs at %L must have an explicit "
    3847                 :            :                      "function interface or be declared as array",
    3848                 :            :                      sym->name, where);
    3849                 :          1 :           return false;
    3850                 :            :         }
    3851                 :            : 
    3852                 :      15591 :       if (sym->attr.allocatable)
    3853                 :            :         {
    3854                 :          1 :           gfc_error ("Allocatable function %qs at %L must have an explicit "
    3855                 :            :                      "function interface", sym->name, where);
    3856                 :          1 :           return false;
    3857                 :            :         }
    3858                 :            : 
    3859                 :      45716 :       for (a = *ap; a; a = a->next)
    3860                 :            :         {
    3861                 :      30136 :           if (a->expr && a->expr->error)
    3862                 :            :             return false;
    3863                 :            : 
    3864                 :            :           /* F2018, 15.4.2.2 Explicit interface is required for a
    3865                 :            :              polymorphic dummy argument, so there is no way to
    3866                 :            :              legally have a class appear in an argument with an
    3867                 :            :              implicit interface.  */
    3868                 :            : 
    3869                 :      30136 :           if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
    3870                 :            :             {
    3871                 :          3 :               gfc_error ("Explicit interface required for polymorphic "
    3872                 :            :                          "argument at %L",&a->expr->where);
    3873                 :          3 :               a->expr->error = 1;
    3874                 :          3 :               break;
    3875                 :            :             }
    3876                 :            : 
    3877                 :            :           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
    3878                 :      30133 :           if (a->name != NULL && a->name[0] != '%')
    3879                 :            :             {
    3880                 :          2 :               gfc_error ("Keyword argument requires explicit interface "
    3881                 :            :                          "for procedure %qs at %L", sym->name, &a->expr->where);
    3882                 :          2 :               break;
    3883                 :            :             }
    3884                 :            : 
    3885                 :            :           /* TS 29113, 6.2.  */
    3886                 :      30131 :           if (a->expr && a->expr->ts.type == BT_ASSUMED
    3887                 :          2 :               && sym->intmod_sym_id != ISOCBINDING_LOC)
    3888                 :            :             {
    3889                 :          2 :               gfc_error ("Assumed-type argument %s at %L requires an explicit "
    3890                 :          2 :                          "interface", a->expr->symtree->n.sym->name,
    3891                 :            :                          &a->expr->where);
    3892                 :          2 :               a->expr->error = 1;
    3893                 :          2 :               break;
    3894                 :            :             }
    3895                 :            : 
    3896                 :            :           /* F2008, C1303 and C1304.  */
    3897                 :      30129 :           if (a->expr
    3898                 :      29954 :               && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
    3899                 :         61 :               && a->expr->ts.u.derived
    3900                 :      30129 :               && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    3901                 :         59 :                    && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
    3902                 :         58 :                   || gfc_expr_attr (a->expr).lock_comp))
    3903                 :            :             {
    3904                 :          1 :               gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
    3905                 :            :                          "component at %L requires an explicit interface for "
    3906                 :          1 :                          "procedure %qs", &a->expr->where, sym->name);
    3907                 :          1 :               a->expr->error = 1;
    3908                 :          1 :               break;
    3909                 :            :             }
    3910                 :            : 
    3911                 :      30128 :           if (a->expr
    3912                 :      29953 :               && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
    3913                 :         60 :               && a->expr->ts.u.derived
    3914                 :      30128 :               && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    3915                 :         58 :                    && a->expr->ts.u.derived->intmod_sym_id
    3916                 :            :                       == ISOFORTRAN_EVENT_TYPE)
    3917                 :         58 :                   || gfc_expr_attr (a->expr).event_comp))
    3918                 :            :             {
    3919                 :          0 :               gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
    3920                 :            :                          "component at %L requires an explicit interface for "
    3921                 :          0 :                          "procedure %qs", &a->expr->where, sym->name);
    3922                 :          0 :               a->expr->error = 1;
    3923                 :          0 :               break;
    3924                 :            :             }
    3925                 :            : 
    3926                 :      30128 :           if (a->expr && a->expr->expr_type == EXPR_NULL
    3927                 :          1 :               && a->expr->ts.type == BT_UNKNOWN)
    3928                 :            :             {
    3929                 :          1 :               gfc_error ("MOLD argument to NULL required at %L",
    3930                 :            :                          &a->expr->where);
    3931                 :          1 :               a->expr->error = 1;
    3932                 :          1 :               return false;
    3933                 :            :             }
    3934                 :            : 
    3935                 :            :           /* TS 29113, C407b.  */
    3936                 :      29952 :           if (a->expr && a->expr->expr_type == EXPR_VARIABLE
    3937                 :      73416 :               && symbol_rank (a->expr->symtree->n.sym) == -1)
    3938                 :            :             {
    3939                 :          1 :               gfc_error ("Assumed-rank argument requires an explicit interface "
    3940                 :            :                          "at %L", &a->expr->where);
    3941                 :          1 :               a->expr->error = 1;
    3942                 :          1 :               return false;
    3943                 :            :             }
    3944                 :            :         }
    3945                 :            : 
    3946                 :      15588 :       return true;
    3947                 :            :     }
    3948                 :            : 
    3949                 :      48535 :   dummy_args = gfc_sym_get_dummy_args (sym);
    3950                 :            : 
    3951                 :            :   /* For a statement function, check that types and type parameters of actual
    3952                 :            :      arguments and dummy arguments match.  */
    3953                 :      48535 :   if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
    3954                 :      48535 :                                   sym->attr.proc == PROC_ST_FUNCTION, where))
    3955                 :            :     return false;
    3956                 :            :  
    3957                 :      48172 :   if (!check_intents (dummy_args, *ap))
    3958                 :            :     return false;
    3959                 :            : 
    3960                 :      48168 :   if (warn_aliasing)
    3961                 :        830 :     check_some_aliasing (dummy_args, *ap);
    3962                 :            : 
    3963                 :            :   return true;
    3964                 :            : }
    3965                 :            : 
    3966                 :            : 
    3967                 :            : /* Check how a procedure pointer component is used against its interface.
    3968                 :            :    If all goes well, the actual argument list will also end up being properly
    3969                 :            :    sorted. Completely analogous to gfc_procedure_use.  */
    3970                 :            : 
    3971                 :            : void
    3972                 :        366 : gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
    3973                 :            : {
    3974                 :            :   /* Warn about calls with an implicit interface.  Special case
    3975                 :            :      for calling a ISO_C_BINDING because c_loc and c_funloc
    3976                 :            :      are pseudo-unknown.  */
    3977                 :        366 :   if (warn_implicit_interface
    3978                 :          0 :       && comp->attr.if_source == IFSRC_UNKNOWN
    3979                 :          0 :       && !comp->attr.is_iso_c)
    3980                 :          0 :     gfc_warning (OPT_Wimplicit_interface,
    3981                 :            :                  "Procedure pointer component %qs called with an implicit "
    3982                 :            :                  "interface at %L", comp->name, where);
    3983                 :            : 
    3984                 :        366 :   if (comp->attr.if_source == IFSRC_UNKNOWN)
    3985                 :            :     {
    3986                 :         45 :       gfc_actual_arglist *a;
    3987                 :         72 :       for (a = *ap; a; a = a->next)
    3988                 :            :         {
    3989                 :            :           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
    3990                 :         27 :           if (a->name != NULL && a->name[0] != '%')
    3991                 :            :             {
    3992                 :          0 :               gfc_error ("Keyword argument requires explicit interface "
    3993                 :            :                          "for procedure pointer component %qs at %L",
    3994                 :          0 :                          comp->name, &a->expr->where);
    3995                 :          0 :               break;
    3996                 :            :             }
    3997                 :            :         }
    3998                 :            : 
    3999                 :         45 :       return;
    4000                 :            :     }
    4001                 :            : 
    4002                 :        321 :   if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0,
    4003                 :        321 :                               comp->attr.elemental, false, where))
    4004                 :            :     return;
    4005                 :            : 
    4006                 :        321 :   check_intents (comp->ts.interface->formal, *ap);
    4007                 :        321 :   if (warn_aliasing)
    4008                 :          0 :     check_some_aliasing (comp->ts.interface->formal, *ap);
    4009                 :            : }
    4010                 :            : 
    4011                 :            : 
    4012                 :            : /* Try if an actual argument list matches the formal list of a symbol,
    4013                 :            :    respecting the symbol's attributes like ELEMENTAL.  This is used for
    4014                 :            :    GENERIC resolution.  */
    4015                 :            : 
    4016                 :            : bool
    4017                 :      50882 : gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
    4018                 :            : {
    4019                 :      50882 :   gfc_formal_arglist *dummy_args;
    4020                 :      50882 :   bool r;
    4021                 :            : 
    4022                 :      50882 :   if (sym->attr.flavor != FL_PROCEDURE)
    4023                 :            :     return false;
    4024                 :            : 
    4025                 :      50880 :   dummy_args = gfc_sym_get_dummy_args (sym);
    4026                 :            : 
    4027                 :      50880 :   r = !sym->attr.elemental;
    4028                 :      50880 :   if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL))
    4029                 :            :     {
    4030                 :      14332 :       check_intents (dummy_args, *args);
    4031                 :      14332 :       if (warn_aliasing)
    4032                 :          1 :         check_some_aliasing (dummy_args, *args);
    4033                 :      14332 :       return true;
    4034                 :            :     }
    4035                 :            : 
    4036                 :            :   return false;
    4037                 :            : }
    4038                 :            : 
    4039                 :            : 
    4040                 :            : /* Given an interface pointer and an actual argument list, search for
    4041                 :            :    a formal argument list that matches the actual.  If found, returns
    4042                 :            :    a pointer to the symbol of the correct interface.  Returns NULL if
    4043                 :            :    not found.  */
    4044                 :            : 
    4045                 :            : gfc_symbol *
    4046                 :      24862 : gfc_search_interface (gfc_interface *intr, int sub_flag,
    4047                 :            :                       gfc_actual_arglist **ap)
    4048                 :            : {
    4049                 :      24862 :   gfc_symbol *elem_sym = NULL;
    4050                 :      24862 :   gfc_symbol *null_sym = NULL;
    4051                 :      24862 :   locus null_expr_loc;
    4052                 :      24862 :   gfc_actual_arglist *a;
    4053                 :      24862 :   bool has_null_arg = false;
    4054                 :            : 
    4055                 :      68411 :   for (a = *ap; a; a = a->next)
    4056                 :      43638 :     if (a->expr && a->expr->expr_type == EXPR_NULL
    4057                 :        126 :         && a->expr->ts.type == BT_UNKNOWN)
    4058                 :            :       {
    4059                 :         89 :         has_null_arg = true;
    4060                 :         89 :         null_expr_loc = a->expr->where;
    4061                 :         89 :         break;
    4062                 :            :       }
    4063                 :            : 
    4064                 :      69116 :   for (; intr; intr = intr->next)
    4065                 :            :     {
    4066                 :      53097 :       if (gfc_fl_struct (intr->sym->attr.flavor))
    4067                 :       3897 :         continue;
    4068                 :      49200 :       if (sub_flag && intr->sym->attr.function)
    4069                 :          0 :         continue;
    4070                 :      49200 :       if (!sub_flag && intr->sym->attr.subroutine)
    4071                 :          0 :         continue;
    4072                 :            : 
    4073                 :      49200 :       if (gfc_arglist_matches_symbol (ap, intr->sym))
    4074                 :            :         {
    4075                 :      13363 :           if (has_null_arg && null_sym)
    4076                 :            :             {
    4077                 :          2 :               gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
    4078                 :            :                          "between specific functions %s and %s",
    4079                 :          2 :                          &null_expr_loc, null_sym->name, intr->sym->name);
    4080                 :          2 :               return NULL;
    4081                 :            :             }
    4082                 :      13361 :           else if (has_null_arg)
    4083                 :            :             {
    4084                 :          4 :               null_sym = intr->sym;
    4085                 :          4 :               continue;
    4086                 :            :             }
    4087                 :            : 
    4088                 :            :           /* Satisfy 12.4.4.1 such that an elemental match has lower
    4089                 :            :              weight than a non-elemental match.  */
    4090                 :      13357 :           if (intr->sym->attr.elemental)
    4091                 :            :             {
    4092                 :       4516 :               elem_sym = intr->sym;
    4093                 :       4516 :               continue;
    4094                 :            :             }
    4095                 :       8841 :           return intr->sym;
    4096                 :            :         }
    4097                 :            :     }
    4098                 :            : 
    4099                 :      16019 :   if (null_sym)
    4100                 :          2 :     return null_sym;
    4101                 :            : 
    4102                 :            :   return elem_sym ? elem_sym : NULL;
    4103                 :            : }
    4104                 :            : 
    4105                 :            : 
    4106                 :            : /* Do a brute force recursive search for a symbol.  */
    4107                 :            : 
    4108                 :            : static gfc_symtree *
    4109                 :      34872 : find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
    4110                 :            : {
    4111                 :      67169 :   gfc_symtree * st;
    4112                 :            : 
    4113                 :      67169 :   if (root->n.sym == sym)
    4114                 :            :     return root;
    4115                 :            : 
    4116                 :      66361 :   st = NULL;
    4117                 :      66361 :   if (root->left)
    4118                 :      34026 :     st = find_symtree0 (root->left, sym);
    4119                 :      66361 :   if (root->right && ! st)
    4120                 :            :     st = find_symtree0 (root->right, sym);
    4121                 :            :   return st;
    4122                 :            : }
    4123                 :            : 
    4124                 :            : 
    4125                 :            : /* Find a symtree for a symbol.  */
    4126                 :            : 
    4127                 :            : gfc_symtree *
    4128                 :       3544 : gfc_find_sym_in_symtree (gfc_symbol *sym)
    4129                 :            : {
    4130                 :       3544 :   gfc_symtree *st;
    4131                 :       3544 :   gfc_namespace *ns;
    4132                 :            : 
    4133                 :            :   /* First try to find it by name.  */
    4134                 :       3544 :   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
    4135                 :       3544 :   if (st && st->n.sym == sym)
    4136                 :            :     return st;
    4137                 :            : 
    4138                 :            :   /* If it's been renamed, resort to a brute-force search.  */
    4139                 :            :   /* TODO: avoid having to do this search.  If the symbol doesn't exist
    4140                 :            :      in the symtree for the current namespace, it should probably be added.  */
    4141                 :        846 :   for (ns = gfc_current_ns; ns; ns = ns->parent)
    4142                 :            :     {
    4143                 :        846 :       st = find_symtree0 (ns->sym_root, sym);
    4144                 :        846 :       if (st)
    4145                 :        808 :         return st;
    4146                 :            :     }
    4147                 :          0 :   gfc_internal_error ("Unable to find symbol %qs", sym->name);
    4148                 :            :   /* Not reached.  */
    4149                 :            : }
    4150                 :            : 
    4151                 :            : 
    4152                 :            : /* See if the arglist to an operator-call contains a derived-type argument
    4153                 :            :    with a matching type-bound operator.  If so, return the matching specific
    4154                 :            :    procedure defined as operator-target as well as the base-object to use
    4155                 :            :    (which is the found derived-type argument with operator).  The generic
    4156                 :            :    name, if any, is transmitted to the final expression via 'gname'.  */
    4157                 :            : 
    4158                 :            : static gfc_typebound_proc*
    4159                 :       8227 : matching_typebound_op (gfc_expr** tb_base,
    4160                 :            :                        gfc_actual_arglist* args,
    4161                 :            :                        gfc_intrinsic_op op, const char* uop,
    4162                 :            :                        const char ** gname)
    4163                 :            : {
    4164                 :       8227 :   gfc_actual_arglist* base;
    4165                 :            : 
    4166                 :      23399 :   for (base = args; base; base = base->next)
    4167                 :      15804 :     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
    4168                 :            :       {
    4169                 :      12607 :         gfc_typebound_proc* tb;
    4170                 :      12607 :         gfc_symbol* derived;
    4171                 :      12607 :         bool result;
    4172                 :            : 
    4173                 :      12607 :         while (base->expr->expr_type == EXPR_OP
    4174                 :      12607 :                && base->expr->value.op.op == INTRINSIC_PARENTHESES)
    4175                 :         62 :           base->expr = base->expr->value.op.op1;
    4176                 :            : 
    4177                 :      12545 :         if (base->expr->ts.type == BT_CLASS)
    4178                 :            :           {
    4179                 :        598 :             if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL
    4180                 :       1193 :                 || !gfc_expr_attr (base->expr).class_ok)
    4181                 :         19 :               continue;
    4182                 :        580 :             derived = CLASS_DATA (base->expr)->ts.u.derived;
    4183                 :            :           }
    4184                 :            :         else
    4185                 :      11946 :           derived = base->expr->ts.u.derived;
    4186                 :            : 
    4187                 :      12526 :         if (op == INTRINSIC_USER)
    4188                 :            :           {
    4189                 :        130 :             gfc_symtree* tb_uop;
    4190                 :            : 
    4191                 :        130 :             gcc_assert (uop);
    4192                 :        130 :             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
    4193                 :            :                                                  false, NULL);
    4194                 :            : 
    4195                 :        130 :             if (tb_uop)
    4196                 :         40 :               tb = tb_uop->n.tb;
    4197                 :            :             else
    4198                 :            :               tb = NULL;
    4199                 :            :           }
    4200                 :            :         else
    4201                 :      12396 :           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
    4202                 :            :                                                 false, NULL);
    4203                 :            : 
    4204                 :            :         /* This means we hit a PRIVATE operator which is use-associated and
    4205                 :            :            should thus not be seen.  */
    4206                 :      12526 :         if (!result)
    4207                 :      11762 :           tb = NULL;
    4208                 :            : 
    4209                 :            :         /* Look through the super-type hierarchy for a matching specific
    4210                 :            :            binding.  */
    4211                 :      12658 :         for (; tb; tb = tb->overridden)
    4212                 :            :           {
    4213                 :        764 :             gfc_tbp_generic* g;
    4214                 :            : 
    4215                 :        764 :             gcc_assert (tb->is_generic);
    4216                 :       1316 :             for (g = tb->u.generic; g; g = g->next)
    4217                 :            :               {
    4218                 :       1184 :                 gfc_symbol* target;
    4219                 :       1184 :                 gfc_actual_arglist* argcopy;
    4220                 :       1184 :                 bool matches;
    4221                 :            : 
    4222                 :       1184 :                 gcc_assert (g->specific);
    4223                 :       1184 :                 if (g->specific->error)
    4224                 :          0 :                   continue;
    4225                 :            : 
    4226                 :       1184 :                 target = g->specific->u.specific->n.sym;
    4227                 :            : 
    4228                 :            :                 /* Check if this arglist matches the formal.  */
    4229                 :       1184 :                 argcopy = gfc_copy_actual_arglist (args);
    4230                 :       1184 :                 matches = gfc_arglist_matches_symbol (&argcopy, target);
    4231                 :       1184 :                 gfc_free_actual_arglist (argcopy);
    4232                 :            : 
    4233                 :            :                 /* Return if we found a match.  */
    4234                 :       1184 :                 if (matches)
    4235                 :            :                   {
    4236                 :        632 :                     *tb_base = base->expr;
    4237                 :        632 :                     *gname = g->specific_st->name;
    4238                 :        632 :                     return g->specific;
    4239                 :            :                   }
    4240                 :            :               }
    4241                 :            :           }
    4242                 :            :       }
    4243                 :            : 
    4244                 :            :   return NULL;
    4245                 :            : }
    4246                 :            : 
    4247                 :            : 
    4248                 :            : /* For the 'actual arglist' of an operator call and a specific typebound
    4249                 :            :    procedure that has been found the target of a type-bound operator, build the
    4250                 :            :    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
    4251                 :            :    type-bound procedures rather than resolving type-bound operators 'directly'
    4252                 :            :    so that we can reuse the existing logic.  */
    4253                 :            : 
    4254                 :            : static void
    4255                 :        632 : build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
    4256                 :            :                              gfc_expr* base, gfc_typebound_proc* target,
    4257                 :            :                              const char *gname)
    4258                 :            : {
    4259                 :        632 :   e->expr_type = EXPR_COMPCALL;
    4260                 :        632 :   e->value.compcall.tbp = target;
    4261                 :        632 :   e->value.compcall.name = gname ? gname : "$op";
    4262                 :        632 :   e->value.compcall.actual = actual;
    4263                 :        632 :   e->value.compcall.base_object = base;
    4264                 :        632 :   e->value.compcall.ignore_pass = 1;
    4265                 :        632 :   e->value.compcall.assign = 0;
    4266                 :        632 :   if (e->ts.type == BT_UNKNOWN
    4267                 :        632 :         && target->function)
    4268                 :            :     {
    4269                 :        313 :       if (target->is_generic)
    4270                 :          0 :         e->ts = target->u.generic->specific->u.specific->n.sym->ts;
    4271                 :            :       else
    4272                 :        313 :         e->ts = target->u.specific->n.sym->ts;
    4273                 :            :     }
    4274                 :        632 : }
    4275                 :            : 
    4276                 :            : 
    4277                 :            : /* This subroutine is called when an expression is being resolved.
    4278                 :            :    The expression node in question is either a user defined operator
    4279                 :            :    or an intrinsic operator with arguments that aren't compatible
    4280                 :            :    with the operator.  This subroutine builds an actual argument list
    4281                 :            :    corresponding to the operands, then searches for a compatible
    4282                 :            :    interface.  If one is found, the expression node is replaced with
    4283                 :            :    the appropriate function call. We use the 'match' enum to specify
    4284                 :            :    whether a replacement has been made or not, or if an error occurred.  */
    4285                 :            : 
    4286                 :            : match
    4287                 :       1634 : gfc_extend_expr (gfc_expr *e)
    4288                 :            : {
    4289                 :       1634 :   gfc_actual_arglist *actual;
    4290                 :       1634 :   gfc_symbol *sym;
    4291                 :       1634 :   gfc_namespace *ns;
    4292                 :       1634 :   gfc_user_op *uop;
    4293                 :       1634 :   gfc_intrinsic_op i;
    4294                 :       1634 :   const char *gname;
    4295                 :       1634 :   gfc_typebound_proc* tbo;
    4296                 :       1634 :   gfc_expr* tb_base;
    4297                 :            : 
    4298                 :       1634 :   sym = NULL;
    4299                 :            : 
    4300                 :       1634 :   actual = gfc_get_actual_arglist ();
    4301                 :       1634 :   actual->expr = e->value.op.op1;
    4302                 :            : 
    4303                 :       1634 :   gname = NULL;
    4304                 :            : 
    4305                 :       1634 :   if (e->value.op.op2 != NULL)
    4306                 :            :     {
    4307                 :       1538 :       actual->next = gfc_get_actual_arglist ();
    4308                 :       1538 :       actual->next->expr = e->value.op.op2;
    4309                 :            :     }
    4310                 :            : 
    4311                 :       1634 :   i = fold_unary_intrinsic (e->value.op.op);
    4312                 :            : 
    4313                 :            :   /* See if we find a matching type-bound operator.  */
    4314                 :       1634 :   if (i == INTRINSIC_USER)
    4315                 :        193 :     tbo = matching_typebound_op (&tb_base, actual,
    4316                 :        193 :                                   i, e->value.op.uop->name, &gname);
    4317                 :            :   else
    4318                 :       1441 :     switch (i)
    4319                 :            :       {
    4320                 :            : #define CHECK_OS_COMPARISON(comp) \
    4321                 :            :   case INTRINSIC_##comp: \
    4322                 :            :   case INTRINSIC_##comp##_OS: \
    4323                 :            :     tbo = matching_typebound_op (&tb_base, actual, \
    4324                 :            :                                  INTRINSIC_##comp, NULL, &gname); \
    4325                 :            :     if (!tbo) \
    4326                 :            :       tbo = matching_typebound_op (&tb_base, actual, \
    4327                 :            :                                    INTRINSIC_##comp##_OS, NULL, &gname); \
    4328                 :            :     break;
    4329                 :        106 :         CHECK_OS_COMPARISON(EQ)
    4330                 :        659 :         CHECK_OS_COMPARISON(NE)
    4331                 :         41 :         CHECK_OS_COMPARISON(GT)
    4332                 :         40 :         CHECK_OS_COMPARISON(GE)
    4333                 :         53 :         CHECK_OS_COMPARISON(LT)
    4334                 :         40 :         CHECK_OS_COMPARISON(LE)
    4335                 :            : #undef CHECK_OS_COMPARISON
    4336                 :            : 
    4337                 :        502 :         default:
    4338                 :        502 :           tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
    4339                 :        502 :           break;
    4340                 :            :       }
    4341                 :            : 
    4342                 :            :   /* If there is a matching typebound-operator, replace the expression with
    4343                 :            :       a call to it and succeed.  */
    4344                 :       1634 :   if (tbo)
    4345                 :            :     {
    4346                 :        313 :       gcc_assert (tb_base);
    4347                 :        313 :       build_compcall_for_operator (e, actual, tb_base, tbo, gname);
    4348                 :            : 
    4349                 :        313 :       if (!gfc_resolve_expr (e))
    4350                 :            :         return MATCH_ERROR;
    4351                 :            :       else
    4352                 :        311 :         return MATCH_YES;
    4353                 :            :     }
    4354                 :            : 
    4355                 :       1321 :   if (i == INTRINSIC_USER)
    4356                 :            :     {
    4357                 :        158 :       for (ns = gfc_current_ns; ns; ns = ns->parent)
    4358                 :            :         {
    4359                 :        154 :           uop = gfc_find_uop (e->value.op.uop->name, ns);
    4360                 :        154 :           if (uop == NULL)
    4361                 :          0 :             continue;
    4362                 :            : 
    4363                 :        154 :           sym = gfc_search_interface (uop->op, 0, &actual);
    4364                 :        154 :           if (sym != NULL)
    4365                 :            :             break;
    4366                 :            :         }
    4367                 :            :     }
    4368                 :            :   else
    4369                 :            :     {
    4370                 :       1373 :       for (ns = gfc_current_ns; ns; ns = ns->parent)
    4371                 :            :         {
    4372                 :            :           /* Due to the distinction between '==' and '.eq.' and friends, one has
    4373                 :            :              to check if either is defined.  */
    4374                 :       1225 :           switch (i)
    4375                 :            :             {
    4376                 :            : #define CHECK_OS_COMPARISON(comp) \
    4377                 :            :   case INTRINSIC_##comp: \
    4378                 :            :   case INTRINSIC_##comp##_OS: \
    4379                 :            :     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
    4380                 :            :     if (!sym) \
    4381                 :            :       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
    4382                 :            :     break;
    4383                 :        106 :               CHECK_OS_COMPARISON(EQ)
    4384                 :        699 :               CHECK_OS_COMPARISON(NE)
    4385                 :         41 :               CHECK_OS_COMPARISON(GT)
    4386                 :         40 :               CHECK_OS_COMPARISON(GE)
    4387                 :         40 :               CHECK_OS_COMPARISON(LT)
    4388                 :         40 :               CHECK_OS_COMPARISON(LE)
    4389                 :            : #undef CHECK_OS_COMPARISON
    4390                 :            : 
    4391                 :        259 :               default:
    4392                 :        259 :                 sym = gfc_search_interface (ns->op[i], 0, &actual);
    4393                 :            :             }
    4394                 :            : 
    4395                 :       1225 :           if (sym != NULL)
    4396                 :            :             break;
    4397                 :            :         }
    4398                 :            :     }
    4399                 :            : 
    4400                 :            :   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
    4401                 :            :      found rather than just taking the first one and not checking further.  */
    4402                 :            : 
    4403                 :       1321 :   if (sym == NULL)
    4404                 :            :     {
    4405                 :            :       /* Don't use gfc_free_actual_arglist().  */
    4406                 :        152 :       free (actual->next);
    4407                 :        152 :       free (actual);
    4408                 :        152 :       return MATCH_NO;
    4409                 :            :     }
    4410                 :            : 
    4411                 :            :   /* Change the expression node to a function call.  */
    4412                 :       1169 :   e->expr_type = EXPR_FUNCTION;
    4413                 :       1169 :   e->symtree = gfc_find_sym_in_symtree (sym);
    4414                 :       1169 :   e->value.function.actual = actual;
    4415                 :       1169 :   e->value.function.esym = NULL;
    4416                 :       1169 :   e->value.function.isym = NULL;
    4417                 :       1169 :   e->value.function.name = NULL;
    4418                 :       1169 :   e->user_operator = 1;
    4419                 :            : 
    4420                 :       1169 :   if (!gfc_resolve_expr (e))
    4421                 :          0 :     return MATCH_ERROR;
    4422                 :            : 
    4423                 :            :   return MATCH_YES;
    4424                 :            : }
    4425                 :            : 
    4426                 :            : 
    4427                 :            : /* Tries to replace an assignment code node with a subroutine call to the
    4428                 :            :    subroutine associated with the assignment operator. Return true if the node
    4429                 :            :    was replaced. On false, no error is generated.  */
    4430                 :            : 
    4431                 :            : bool
    4432                 :     140446 : gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
    4433                 :            : {
    4434                 :     140446 :   gfc_actual_arglist *actual;
    4435                 :     140446 :   gfc_expr *lhs, *rhs, *tb_base;
    4436                 :     140446 :   gfc_symbol *sym = NULL;
    4437                 :     140446 :   const char *gname = NULL;
    4438                 :     140446 :   gfc_typebound_proc* tbo;
    4439                 :            : 
    4440                 :     140446 :   lhs = c->expr1;
    4441                 :     140446 :   rhs = c->expr2;
    4442                 :            : 
    4443                 :            :   /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced.  */
    4444                 :     140446 :   if (c->op == EXEC_ASSIGN
    4445                 :     140446 :       && c->expr1->expr_type == EXPR_VARIABLE
    4446                 :     140446 :       && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ)
    4447                 :            :     return false;
    4448                 :            : 
    4449                 :            :   /* Don't allow an intrinsic assignment to be replaced.  */
    4450                 :     140443 :   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
    4451                 :     135904 :       && (rhs->rank == 0 || rhs->rank == lhs->rank)
    4452                 :     276326 :       && (lhs->ts.type == rhs->ts.type
    4453                 :       6002 :           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
    4454                 :     134789 :     return false;
    4455                 :            : 
    4456                 :       5654 :   actual = gfc_get_actual_arglist ();
    4457                 :       5654 :   actual->expr = lhs;
    4458                 :            : 
    4459                 :       5654 :   actual->next = gfc_get_actual_arglist ();
    4460                 :       5654 :   actual->next->expr = rhs;
    4461                 :            : 
    4462                 :            :   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
    4463                 :            : 
    4464                 :            :   /* See if we find a matching type-bound assignment.  */
    4465                 :       5654 :   tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
    4466                 :            :                                NULL, &gname);
    4467                 :            : 
    4468                 :       5654 :   if (tbo)
    4469                 :            :     {
    4470                 :            :       /* Success: Replace the expression with a type-bound call.  */
    4471                 :        319 :       gcc_assert (tb_base);
    4472                 :        319 :       c->expr1 = gfc_get_expr ();
    4473                 :        319 :       build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
    4474                 :        319 :       c->expr1->value.compcall.assign = 1;
    4475                 :        319 :       c->expr1->where = c->loc;
    4476                 :        319 :       c->expr2 = NULL;
    4477                 :        319 :       c->op = EXEC_COMPCALL;
    4478                 :        319 :       return true;
    4479                 :            :     }
    4480                 :            : 
    4481                 :            :   /* See if we find an 'ordinary' (non-typebound) assignment procedure.  */
    4482                 :      12426 :   for (; ns; ns = ns->parent)
    4483                 :            :     {
    4484                 :       7399 :       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
    4485                 :       7399 :       if (sym != NULL)
    4486                 :            :         break;
    4487                 :            :     }
    4488                 :            : 
    4489                 :       5335 :   if (sym)
    4490                 :            :     {
    4491                 :            :       /* Success: Replace the assignment with the call.  */
    4492                 :        308 :       c->op = EXEC_ASSIGN_CALL;
    4493                 :        308 :       c->symtree = gfc_find_sym_in_symtree (sym);
    4494                 :        308 :       c->expr1 = NULL;
    4495                 :        308 :       c->expr2 = NULL;
    4496                 :        308 :       c->ext.actual = actual;
    4497                 :        308 :       return true;
    4498                 :            :     }
    4499                 :            : 
    4500                 :            :   /* Failure: No assignment procedure found.  */
    4501                 :       5027 :   free (actual->next);
    4502                 :       5027 :   free (actual);
    4503                 :       5027 :   return false;
    4504                 :            : }
    4505                 :            : 
    4506                 :            : 
    4507                 :            : /* Make sure that the interface just parsed is not already present in
    4508                 :            :    the given interface list.  Ambiguity isn't checked yet since module
    4509                 :            :    procedures can be present without interfaces.  */
    4510                 :            : 
    4511                 :            : bool
    4512                 :       8127 : gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
    4513                 :            : {
    4514                 :       8127 :   gfc_interface *ip;
    4515                 :            : 
    4516                 :      16268 :   for (ip = base; ip; ip = ip->next)
    4517                 :            :     {
    4518                 :       8148 :       if (ip->sym == new_sym)
    4519                 :            :         {
    4520                 :          7 :           gfc_error ("Entity %qs at %L is already present in the interface",
    4521                 :            :                      new_sym->name, &loc);
    4522                 :          7 :           return false;
    4523                 :            :         }
    4524                 :            :     }
    4525                 :            : 
    4526                 :            :   return true;
    4527                 :            : }
    4528                 :            : 
    4529                 :            : 
    4530                 :            : /* Add a symbol to the current interface.  */
    4531                 :            : 
    4532                 :            : bool
    4533                 :      11339 : gfc_add_interface (gfc_symbol *new_sym)
    4534                 :            : {
    4535                 :      11339 :   gfc_interface **head, *intr;
    4536                 :      11339 :   gfc_namespace *ns;
    4537                 :      11339 :   gfc_symbol *sym;
    4538                 :            : 
    4539                 :      11339 :   switch (current_interface.type)
    4540                 :            :     {
    4541                 :            :     case INTERFACE_NAMELESS:
    4542                 :            :     case INTERFACE_ABSTRACT:
    4543                 :            :       return true;
    4544                 :            : 
    4545                 :        532 :     case INTERFACE_INTRINSIC_OP:
    4546                 :       1067 :       for (ns = current_interface.ns; ns; ns = ns->parent)
    4547                 :        538 :         switch (current_interface.op)
    4548                 :            :           {
    4549                 :         52 :             case INTRINSIC_EQ:
    4550                 :         52 :             case INTRINSIC_EQ_OS:
    4551                 :         52 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
    4552                 :            :                                             gfc_current_locus)
    4553                 :         52 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
    4554                 :            :                                                new_sym, gfc_current_locus))
    4555                 :          2 :                 return false;
    4556                 :            :               break;
    4557                 :            : 
    4558                 :         40 :             case INTRINSIC_NE:
    4559                 :         40 :             case INTRINSIC_NE_OS:
    4560                 :         40 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
    4561                 :            :                                             gfc_current_locus)
    4562                 :         40 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
    4563                 :            :                                                new_sym, gfc_current_locus))
    4564                 :          0 :                 return false;
    4565                 :            :               break;
    4566                 :            : 
    4567                 :         17 :             case INTRINSIC_GT:
    4568                 :         17 :             case INTRINSIC_GT_OS:
    4569                 :         17 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
    4570                 :            :                                             new_sym, gfc_current_locus)
    4571                 :         17 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
    4572                 :            :                                                new_sym, gfc_current_locus))
    4573                 :          0 :                 return false;
    4574                 :            :               break;
    4575                 :            : 
    4576                 :         15 :             case INTRINSIC_GE:
    4577                 :         15 :             case INTRINSIC_GE_OS:
    4578                 :         15 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
    4579                 :            :                                             new_sym, gfc_current_locus)
    4580                 :         15 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
    4581                 :            :                                                new_sym, gfc_current_locus))
    4582                 :          0 :                 return false;
    4583                 :            :               break;
    4584                 :            : 
    4585                 :         15 :             case INTRINSIC_LT:
    4586                 :         15 :             case INTRINSIC_LT_OS:
    4587                 :         15 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
    4588                 :            :                                             new_sym, gfc_current_locus)
    4589                 :         15 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
    4590                 :            :                                                new_sym, gfc_current_locus))
    4591                 :          0 :                 return false;
    4592                 :            :               break;
    4593                 :            : 
    4594                 :         15 :             case INTRINSIC_LE:
    4595                 :         15 :             case INTRINSIC_LE_OS:
    4596                 :         15 :               if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
    4597                 :            :                                             new_sym, gfc_current_locus)
    4598                 :         15 :                   || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
    4599                 :            :                                                new_sym, gfc_current_locus))
    4600                 :          0 :                 return false;
    4601                 :            :               break;
    4602                 :            : 
    4603                 :        384 :             default:
    4604                 :        384 :               if (!gfc_check_new_interface (ns->op[current_interface.op],
    4605                 :            :                                             new_sym, gfc_current_locus))
    4606                 :            :                 return false;
    4607                 :            :           }
    4608                 :            : 
    4609                 :        529 :       head = &current_interface.ns->op[current_interface.op];
    4610                 :        529 :       break;
    4611                 :            : 
    4612                 :       7028 :     case INTERFACE_GENERIC:
    4613                 :       7028 :     case INTERFACE_DTIO:
    4614                 :      14065 :       for (ns = current_interface.ns; ns; ns = ns->parent)
    4615                 :            :         {
    4616                 :       7038 :           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
    4617                 :       7038 :           if (sym == NULL)
    4618                 :         10 :             continue;
    4619                 :            : 
    4620                 :       7028 :           if (!gfc_check_new_interface (sym->generic,
    4621                 :            :                                         new_sym, gfc_current_locus))
    4622                 :            :             return false;
    4623                 :            :         }
    4624                 :            : 
    4625                 :       7027 :       head = &current_interface.sym->generic;
    4626                 :       7027 :       break;
    4627                 :            : 
    4628                 :        133 :     case INTERFACE_USER_OP:
    4629                 :        133 :       if (!gfc_check_new_interface (current_interface.uop->op,
    4630                 :            :                                     new_sym, gfc_current_locus))
    4631                 :            :         return false;
    4632                 :            : 
    4633                 :        132 :       head = &current_interface.uop->op;
    4634                 :        132 :       break;
    4635                 :            : 
    4636                 :          0 :     default:
    4637                 :          0 :       gfc_internal_error ("gfc_add_interface(): Bad interface type");
    4638                 :            :     }
    4639                 :            : 
    4640                 :       7688 :   intr = gfc_get_interface ();
    4641                 :       7688 :   intr->sym = new_sym;
    4642                 :       7688 :   intr->where = gfc_current_locus;
    4643                 :            : 
    4644                 :       7688 :   intr->next = *head;
    4645                 :       7688 :   *head = intr;
    4646                 :            : 
    4647                 :       7688 :   return true;
    4648                 :            : }
    4649                 :            : 
    4650                 :            : 
    4651                 :            : gfc_interface *
    4652                 :       1213 : gfc_current_interface_head (void)
    4653                 :            : {
    4654                 :       1213 :   switch (current_interface.type)
    4655                 :            :     {
    4656                 :        415 :       case INTERFACE_INTRINSIC_OP:
    4657                 :        415 :         return current_interface.ns->op[current_interface.op];
    4658                 :            : 
    4659                 :        673 :       case INTERFACE_GENERIC:
    4660                 :        673 :       case INTERFACE_DTIO:
    4661                 :        673 :         return current_interface.sym->generic;
    4662                 :            : 
    4663                 :        125 :       case INTERFACE_USER_OP:
    4664                 :        125 :         return current_interface.uop->op;
    4665                 :            : 
    4666                 :          0 :       default:
    4667                 :          0 :         gcc_unreachable ();
    4668                 :            :     }
    4669                 :            : }
    4670                 :            : 
    4671                 :            : 
    4672                 :            : void
    4673                 :          3 : gfc_set_current_interface_head (gfc_interface *i)
    4674                 :            : {
    4675                 :          3 :   switch (current_interface.type)
    4676                 :            :     {
    4677                 :          0 :       case INTERFACE_INTRINSIC_OP:
    4678                 :          0 :         current_interface.ns->op[current_interface.op] = i;
    4679                 :          0 :         break;
    4680                 :            : 
    4681                 :          3 :       case INTERFACE_GENERIC:
    4682                 :          3 :       case INTERFACE_DTIO:
    4683                 :          3 :         current_interface.sym->generic = i;
    4684                 :          3 :         break;
    4685                 :            : 
    4686                 :          0 :       case INTERFACE_USER_OP:
    4687                 :          0 :         current_interface.uop->op = i;
    4688                 :          0 :         break;
    4689                 :            : 
    4690                 :          0 :       default:
    4691                 :          0 :         gcc_unreachable ();
    4692                 :            :     }
    4693                 :          3 : }
    4694                 :            : 
    4695                 :            : 
    4696                 :            : /* Gets rid of a formal argument list.  We do not free symbols.
    4697                 :            :    Symbols are freed when a namespace is freed.  */
    4698                 :            : 
    4699                 :            : void
    4700                 :    3625060 : gfc_free_formal_arglist (gfc_formal_arglist *p)
    4701                 :            : {
    4702                 :    3949440 :   gfc_formal_arglist *q;
    4703                 :            : 
    4704                 :    3949440 :   for (; p; p = q)
    4705                 :            :     {
    4706                 :     324384 :       q = p->next;
    4707                 :     324384 :       free (p);
    4708                 :            :     }
    4709                 :    3625060 : }
    4710                 :            : 
    4711                 :            : 
    4712                 :            : /* Check that it is ok for the type-bound procedure 'proc' to override the
    4713                 :            :    procedure 'old', cf. F08:4.5.7.3.  */
    4714                 :            : 
    4715                 :            : bool
    4716                 :       1103 : gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
    4717                 :            : {
    4718                 :       1103 :   locus where;
    4719                 :       1103 :   gfc_symbol *proc_target, *old_target;
    4720                 :       1103 :   unsigned proc_pass_arg, old_pass_arg, argpos;
    4721                 :       1103 :   gfc_formal_arglist *proc_formal, *old_formal;
    4722                 :       1103 :   bool check_type;
    4723                 :       1103 :   char err[200];
    4724                 :            : 
    4725                 :            :   /* This procedure should only be called for non-GENERIC proc.  */
    4726                 :       1103 :   gcc_assert (!proc->n.tb->is_generic);
    4727                 :            : 
    4728                 :            :   /* If the overwritten procedure is GENERIC, this is an error.  */
    4729                 :       1103 :   if (old->n.tb->is_generic)
    4730                 :            :     {
    4731                 :          1 :       gfc_error ("Cannot overwrite GENERIC %qs at %L",
    4732                 :            :                  old->name, &proc->n.tb->where);
    4733                 :          1 :       return false;
    4734                 :            :     }
    4735                 :            : 
    4736                 :       1102 :   where = proc->n.tb->where;
    4737                 :       1102 :   proc_target = proc->n.tb->u.specific->n.sym;
    4738                 :       1102 :   old_target = old->n.tb->u.specific->n.sym;
    4739                 :            : 
    4740                 :            :   /* Check that overridden binding is not NON_OVERRIDABLE.  */
    4741                 :       1102 :   if (old->n.tb->non_overridable)
    4742                 :            :     {
    4743                 :          1 :       gfc_error ("%qs at %L overrides a procedure binding declared"
    4744                 :            :                  " NON_OVERRIDABLE", proc->name, &where);
    4745                 :          1 :       return false;
    4746                 :            :     }
    4747                 :            : 
    4748                 :            :   /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
    4749                 :       1101 :   if (!old->n.tb->deferred && proc->n.tb->deferred)
    4750                 :            :     {
    4751                 :          1 :       gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
    4752                 :            :                  " non-DEFERRED binding", proc->name, &where);
    4753                 :          1 :       return false;
    4754                 :            :     }
    4755                 :            : 
    4756                 :            :   /* If the overridden binding is PURE, the overriding must be, too.  */
    4757                 :       1100 :   if (old_target->attr.pure && !proc_target->attr.pure)
    4758                 :            :     {
    4759                 :          2 :       gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
    4760                 :            :                  proc->name, &where);
    4761                 :          2 :       return false;
    4762                 :            :     }
    4763                 :            : 
    4764                 :            :   /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
    4765                 :            :      is not, the overriding must not be either.  */
    4766                 :       1098 :   if (old_target->attr.elemental && !proc_target->attr.elemental)
    4767                 :            :     {
    4768                 :          0 :       gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
    4769                 :            :                  " ELEMENTAL", proc->name, &where);
    4770                 :          0 :       return false;
    4771                 :            :     }
    4772                 :       1098 :   if (!old_target->attr.elemental && proc_target->attr.elemental)
    4773                 :            :     {
    4774                 :          1 :       gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
    4775                 :            :                  " be ELEMENTAL, either", proc->name, &where);
    4776                 :          1 :       return false;
    4777                 :            :     }
    4778                 :            : 
    4779                 :            :   /* If the overridden binding is a SUBROUTINE, the overriding must also be a
    4780                 :            :      SUBROUTINE.  */
    4781                 :       1097 :   if (old_target->attr.subroutine && !proc_target->attr.subroutine)
    4782                 :            :     {
    4783                 :          1 :       gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
    4784                 :            :                  " SUBROUTINE", proc->name, &where);
    4785                 :          1 :       return false;
    4786                 :            :     }
    4787                 :            : 
    4788                 :            :   /* If the overridden binding is a FUNCTION, the overriding must also be a
    4789                 :            :      FUNCTION and have the same characteristics.  */
    4790                 :       1096 :   if (old_target->attr.function)
    4791                 :            :     {
    4792                 :        587 :       if (!proc_target->attr.function)
    4793                 :            :         {
    4794                 :          1 :           gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
    4795                 :            :                      " FUNCTION", proc->name, &where);
    4796                 :          1 :           return false;
    4797                 :            :         }
    4798                 :            : 
    4799                 :        586 :       if (!gfc_check_result_characteristics (proc_target, old_target,
    4800                 :            :                                              err, sizeof(err)))
    4801                 :            :         {
    4802                 :          6 :           gfc_error ("Result mismatch for the overriding procedure "
    4803                 :            :                      "%qs at %L: %s", proc->name, &where, err);
    4804                 :          6 :           return false;
    4805                 :            :         }
    4806                 :            :     }
    4807                 :            : 
    4808                 :            :   /* If the overridden binding is PUBLIC, the overriding one must not be
    4809                 :            :      PRIVATE.  */
    4810                 :       1089 :   if (old->n.tb->access == ACCESS_PUBLIC
    4811                 :       1064 :       && proc->n.tb->access == ACCESS_PRIVATE)
    4812                 :            :     {
    4813                 :          1 :       gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
    4814                 :            :                  " PRIVATE", proc->name, &where);
    4815                 :          1 :       return false;
    4816                 :            :     }
    4817                 :            : 
    4818                 :            :   /* Compare the formal argument lists of both procedures.  This is also abused
    4819                 :            :      to find the position of the passed-object dummy arguments of both
    4820                 :            :      bindings as at least the overridden one might not yet be resolved and we
    4821                 :            :      need those positions in the check below.  */
    4822                 :       1088 :   proc_pass_arg = old_pass_arg = 0;
    4823                 :       1088 :   if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
    4824                 :        684 :     proc_pass_arg = 1;
    4825                 :       1088 :   if (!old->n.tb->nopass && !old->n.tb->pass_arg)
    4826                 :        683 :     old_pass_arg = 1;
    4827                 :       1088 :   argpos = 1;
    4828                 :       1088 :   proc_formal = gfc_sym_get_dummy_args (proc_target);
    4829                 :       1088 :   old_formal = gfc_sym_get_dummy_args (old_target);
    4830                 :       2904 :   for ( ; proc_formal && old_formal;
    4831                 :       1816 :        proc_formal = proc_formal->next, old_formal = old_formal->next)
    4832                 :            :     {
    4833                 :       1823 :       if (proc->n.tb->pass_arg
    4834                 :        479 :           && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
    4835                 :        370 :         proc_pass_arg = argpos;
    4836                 :       1823 :       if (old->n.tb->pass_arg
    4837                 :        481 :           && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
    4838                 :        371 :         old_pass_arg = argpos;
    4839                 :            : 
    4840                 :            :       /* Check that the names correspond.  */
    4841                 :       1823 :       if (strcmp (proc_formal->sym->name, old_formal->sym->name))
    4842                 :            :         {
    4843                 :          1 :           gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
    4844                 :            :                      " to match the corresponding argument of the overridden"
    4845                 :            :                      " procedure", proc_formal->sym->name, proc->name, &where,
    4846                 :            :                      old_formal->sym->name);
    4847                 :          1 :           return false;
    4848                 :            :         }
    4849                 :            : 
    4850                 :       1822 :       check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
    4851                 :       1822 :       if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
    4852                 :            :                                         check_type, err, sizeof(err)))
    4853                 :            :         {
    4854                 :          6 :           gfc_error_opt (0, "Argument mismatch for the overriding procedure "
    4855                 :            :                          "%qs at %L: %s", proc->name, &where, err);
    4856                 :          6 :           return false;
    4857                 :            :         }
    4858                 :            : 
    4859                 :       1816 :       ++argpos;
    4860                 :            :     }
    4861                 :       1081 :   if (proc_formal || old_formal)
    4862                 :            :     {
    4863                 :          1 :       gfc_error ("%qs at %L must have the same number of formal arguments as"
    4864                 :            :                  " the overridden procedure", proc->name, &where);
    4865                 :          1 :       return false;
    4866                 :            :     }
    4867                 :            : 
    4868                 :            :   /* If the overridden binding is NOPASS, the overriding one must also be
    4869                 :            :      NOPASS.  */
    4870                 :       1080 :   if (old->n.tb->nopass && !proc->n.tb->nopass)
    4871                 :            :     {
    4872                 :          1 :       gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
    4873                 :            :                  " NOPASS", proc->name, &where);
    4874                 :          1 :       return false;
    4875                 :            :     }
    4876                 :            : 
    4877                 :            :   /* If the overridden binding is PASS(x), the overriding one must also be
    4878                 :            :      PASS and the passed-object dummy arguments must correspond.  */
    4879                 :       1079 :   if (!old->n.tb->nopass)
    4880                 :            :     {
    4881                 :       1047 :       if (proc->n.tb->nopass)
    4882                 :            :         {
    4883                 :          1 :           gfc_error ("%qs at %L overrides a binding with PASS and must also be"
    4884                 :            :                      " PASS", proc->name, &where);
    4885                 :          1 :           return false;
    4886                 :            :         }
    4887                 :            : 
    4888                 :       1046 :       if (proc_pass_arg != old_pass_arg)
    4889                 :            :         {
    4890                 :          1 :           gfc_error ("Passed-object dummy argument of %qs at %L must be at"
    4891                 :            :                      " the same position as the passed-object dummy argument of"
    4892                 :            :                      " the overridden procedure", proc->name, &where);
    4893                 :          1 :           return false;
    4894                 :            :         }
    4895                 :            :     }
    4896                 :            : 
    4897                 :            :   return true;
    4898                 :            : }
    4899                 :            : 
    4900                 :            : 
    4901                 :            : /* The following three functions check that the formal arguments
    4902                 :            :    of user defined derived type IO procedures are compliant with
    4903                 :            :    the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3).  */
    4904                 :            : 
    4905                 :            : static void
    4906                 :       3748 : check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
    4907                 :            :                            int kind, int rank, sym_intent intent)
    4908                 :            : {
    4909                 :       3748 :   if (fsym->ts.type != type)
    4910                 :            :     {
    4911                 :          3 :       gfc_error ("DTIO dummy argument at %L must be of type %s",
    4912                 :            :                  &fsym->declared_at, gfc_basic_typename (type));
    4913                 :          3 :       return;
    4914                 :            :     }
    4915                 :            : 
    4916                 :       3745 :   if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
    4917                 :       3081 :       && fsym->ts.kind != kind)
    4918                 :          1 :     gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
    4919                 :            :                &fsym->declared_at, kind);
    4920                 :            : 
    4921                 :       3745 :   if (!typebound
    4922                 :       3745 :       && rank == 0
    4923                 :        714 :       && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
    4924                 :        714 :           || ((type != BT_CLASS) && fsym->attr.dimension)))
    4925                 :          0 :     gfc_error ("DTIO dummy argument at %L must be a scalar",
    4926                 :            :                &fsym->declared_at);
    4927                 :       3745 :   else if (rank == 1
    4928                 :        541 :            && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
    4929                 :          1 :     gfc_error ("DTIO dummy argument at %L must be an "
    4930                 :            :                "ASSUMED SHAPE ARRAY", &fsym->declared_at);
    4931                 :            : 
    4932                 :       3745 :   if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)
    4933                 :          1 :     gfc_error ("DTIO character argument at %L must have assumed length",
    4934                 :            :                &fsym->declared_at);
    4935                 :            : 
    4936                 :       3745 :   if (fsym->attr.intent != intent)
    4937                 :          1 :     gfc_error ("DTIO dummy argument at %L must have INTENT %s",
    4938                 :            :                &fsym->declared_at, gfc_code2string (intents, (int)intent));
    4939                 :            :   return;
    4940                 :            : }
    4941                 :            : 
    4942                 :            : 
    4943                 :            : static void
    4944                 :        751 : check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
    4945                 :            :                        bool typebound, bool formatted, int code)
    4946                 :            : {
    4947                 :        751 :   gfc_symbol *dtio_sub, *generic_proc, *fsym;
    4948                 :        751 :   gfc_typebound_proc *tb_io_proc, *specific_proc;
    4949                 :        751 :   gfc_interface *intr;
    4950                 :        751 :   gfc_formal_arglist *formal;
    4951                 :        751 :   int arg_num;
    4952                 :            : 
    4953                 :        751 :   bool read = ((dtio_codes)code == DTIO_RF)
    4954                 :        751 :                || ((dtio_codes)code == DTIO_RUF);
    4955                 :        751 :   bt type;
    4956                 :        751 :   sym_intent intent;
    4957                 :        751 :   int kind;
    4958                 :            : 
    4959                 :        751 :   dtio_sub = NULL;
    4960                 :        751 :   if (typebound)
    4961                 :            :     {
    4962                 :            :       /* Typebound DTIO binding.  */
    4963                 :        513 :       tb_io_proc = tb_io_st->n.tb;
    4964                 :        513 :       if (tb_io_proc == NULL)
    4965                 :            :         return;
    4966                 :            : 
    4967                 :        513 :       gcc_assert (tb_io_proc->is_generic);
    4968                 :            : 
    4969                 :        513 :       specific_proc = tb_io_proc->u.generic->specific;
    4970                 :        513 :       if (specific_proc == NULL || specific_proc->is_generic)
    4971                 :            :         return;
    4972                 :            : 
    4973                 :        513 :       dtio_sub = specific_proc->u.specific->n.sym;
    4974                 :            :     }
    4975                 :            :   else
    4976                 :            :     {
    4977                 :        238 :       generic_proc = tb_io_st->n.sym;
    4978                 :        238 :       if (generic_proc == NULL || generic_proc->generic == NULL)
    4979                 :            :         return;
    4980                 :            : 
    4981                 :        315 :       for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
    4982                 :            :         {
    4983                 :        242 :           if (intr->sym && intr->sym->formal && intr->sym->formal->sym
    4984                 :        238 :               && ((intr->sym->formal->sym->ts.type == BT_CLASS
    4985                 :        141 :                    && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
    4986                 :            :                                                              == derived)
    4987                 :        125 :                   || (intr->sym->formal->sym->ts.type == BT_DERIVED
    4988                 :         97 :                       && intr->sym->formal->sym->ts.u.derived == derived)))
    4989                 :            :             {
    4990                 :            :               dtio_sub = intr->sym;
    4991                 :            :               break;
    4992                 :            :             }
    4993                 :         80 :           else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
    4994                 :            :             {
    4995                 :          1 :               gfc_error ("Alternate return at %L is not permitted in a DTIO "
    4996                 :            :                          "procedure", &intr->sym->declared_at);
    4997                 :          1 :               return;
    4998                 :            :             }
    4999                 :            :         }
    5000                 :            : 
    5001                 :        235 :       if (dtio_sub == NULL)
    5002                 :            :         return;
    5003                 :            :     }
    5004                 :            : 
    5005                 :        675 :   gcc_assert (dtio_sub);
    5006                 :        675 :   if (!dtio_sub->attr.subroutine)
    5007                 :          0 :     gfc_error ("DTIO procedure %qs at %L must be a subroutine",
    5008                 :            :                dtio_sub->name, &dtio_sub->declared_at);
    5009                 :            : 
    5010                 :        675 :   arg_num = 0;
    5011                 :       4454 :   for (formal = dtio_sub->formal; formal; formal = formal->next)
    5012                 :       3779 :     arg_num++;
    5013                 :            : 
    5014                 :        804 :   if (arg_num < (formatted ? 6 : 4))
    5015                 :            :     {
    5016                 :          5 :       gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
    5017                 :            :                  dtio_sub->name, &dtio_sub->declared_at);
    5018                 :          5 :       return;
    5019                 :            :     }
    5020                 :            : 
    5021                 :        670 :   if (arg_num > (formatted ? 6 : 4))
    5022                 :            :     {
    5023                 :          3 :       gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
    5024                 :            :                  dtio_sub->name, &dtio_sub->declared_at);
    5025                 :          3 :       return;
    5026                 :            :     }
    5027                 :            : 
    5028                 :            : 
    5029                 :            :   /* Now go through the formal arglist.  */
    5030                 :            :   arg_num = 1;
    5031                 :       4415 :   for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
    5032                 :            :     {
    5033                 :       3749 :       if (!formatted && arg_num == 3)
    5034                 :        126 :         arg_num = 5;
    5035                 :       3749 :       fsym = formal->sym;
    5036                 :            : 
    5037                 :       3749 :       if (fsym == NULL)
    5038                 :            :         {
    5039                 :          1 :           gfc_error ("Alternate return at %L is not permitted in a DTIO "
    5040                 :            :                      "procedure", &dtio_sub->declared_at);
    5041                 :          1 :           return;
    5042                 :            :         }
    5043                 :            : 
    5044                 :       3748 :       switch (arg_num)
    5045                 :            :         {
    5046                 :        667 :         case(1):                        /* DTV  */
    5047                 :        667 :           type = derived->attr.sequence || derived->attr.is_bind_c ?
    5048                 :            :                  BT_DERIVED : BT_CLASS;
    5049                 :        667 :           kind = 0;
    5050                 :        667 :           intent = read ? INTENT_INOUT : INTENT_IN;
    5051                 :        667 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5052                 :            :                                      0, intent);
    5053                 :        667 :           break;
    5054                 :            : 
    5055                 :        667 :         case(2):                        /* UNIT  */
    5056                 :        667 :           type = BT_INTEGER;
    5057                 :        667 :           kind = gfc_default_integer_kind;
    5058                 :        667 :           intent = INTENT_IN;
    5059                 :        667 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5060                 :            :                                      0, intent);
    5061                 :        667 :           break;
    5062                 :        541 :         case(3):                        /* IOTYPE  */
    5063                 :        541 :           type = BT_CHARACTER;
    5064                 :        541 :           kind = gfc_default_character_kind;
    5065                 :        541 :           intent = INTENT_IN;
    5066                 :        541 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5067                 :            :                                      0, intent);
    5068                 :        541 :           break;
    5069                 :        541 :         case(4):                        /* VLIST  */
    5070                 :        541 :           type = BT_INTEGER;
    5071                 :        541 :           kind = gfc_default_integer_kind;
    5072                 :        541 :           intent = INTENT_IN;
    5073                 :        541 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5074                 :            :                                      1, intent);
    5075                 :        541 :           break;
    5076                 :        666 :         case(5):                        /* IOSTAT  */
    5077                 :        666 :           type = BT_INTEGER;
    5078                 :        666 :           kind = gfc_default_integer_kind;
    5079                 :        666 :           intent = INTENT_OUT;
    5080                 :        666 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5081                 :            :                                      0, intent);
    5082                 :        666 :           break;
    5083                 :        666 :         case(6):                        /* IOMSG  */
    5084                 :        666 :           type = BT_CHARACTER;
    5085                 :        666 :           kind = gfc_default_character_kind;
    5086                 :        666 :           intent = INTENT_INOUT;
    5087                 :        666 :           check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
    5088                 :            :                                      0, intent);
    5089                 :        666 :           break;
    5090                 :          0 :         default:
    5091                 :          0 :           gcc_unreachable ();
    5092                 :            :         }
    5093                 :            :     }
    5094                 :        666 :   derived->attr.has_dtio_procs = 1;
    5095                 :        666 :   return;
    5096                 :            : }
    5097                 :            : 
    5098                 :            : void
    5099                 :      40832 : gfc_check_dtio_interfaces (gfc_symbol *derived)
    5100                 :            : {
    5101                 :      40832 :   gfc_symtree *tb_io_st;
    5102                 :      40832 :   bool t = false;
    5103                 :      40832 :   int code;
    5104                 :      40832 :   bool formatted;
    5105                 :            : 
    5106                 :      40832 :   if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
    5107                 :      20242 :     return;
    5108                 :            : 
    5109                 :            :   /* Check typebound DTIO bindings.  */
    5110                 :     102950 :   for (code = 0; code < 4; code++)
    5111                 :            :     {
    5112                 :      82360 :       formatted = ((dtio_codes)code == DTIO_RF)
    5113                 :      82360 :                    || ((dtio_codes)code == DTIO_WF);
    5114                 :            : 
    5115                 :      82360 :       tb_io_st = gfc_find_typebound_proc (derived, &t,
    5116                 :            :                                           gfc_code2string (dtio_procs, code),
    5117                 :            :                                           true, &derived->declared_at);
    5118                 :      82360 :       if (tb_io_st != NULL)
    5119                 :        513 :         check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
    5120                 :            :     }
    5121                 :            : 
    5122                 :            :   /* Check generic DTIO interfaces.  */
    5123                 :     102950 :   for (code = 0; code < 4; code++)
    5124                 :            :     {
    5125                 :      82360 :       formatted = ((dtio_codes)code == DTIO_RF)
    5126                 :      82360 :                    || ((dtio_codes)code == DTIO_WF);
    5127                 :            : 
    5128                 :      82360 :       tb_io_st = gfc_find_symtree (derived->ns->sym_root,
    5129                 :            :                                    gfc_code2string (dtio_procs, code));
    5130                 :      82360 :       if (tb_io_st != NULL)
    5131                 :        238 :         check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
    5132                 :            :     }
    5133                 :            : }
    5134                 :            : 
    5135                 :            : 
    5136                 :            : gfc_symtree*
    5137                 :       4048 : gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
    5138                 :            : {
    5139                 :       4048 :   gfc_symtree *tb_io_st = NULL;
    5140                 :       4048 :   bool t = false;
    5141                 :            : 
    5142                 :       4048 :   if (!derived || !derived->resolved || derived->attr.flavor != FL_DERIVED)
    5143                 :            :     return NULL;
    5144                 :            : 
    5145                 :            :   /* Try to find a typebound DTIO binding.  */
    5146                 :       4042 :   if (formatted == true)
    5147                 :            :     {
    5148                 :       3825 :       if (write == true)
    5149                 :       1800 :         tb_io_st = gfc_find_typebound_proc (derived, &t,
    5150                 :            :                                             gfc_code2string (dtio_procs,
    5151                 :            :                                                              DTIO_WF),
    5152                 :            :                                             true,
    5153                 :            :                                             &derived->declared_at);
    5154                 :            :       else
    5155                 :       2025 :         tb_io_st = gfc_find_typebound_proc (derived, &t,
    5156                 :            :                                             gfc_code2string (dtio_procs,
    5157                 :            :                                                              DTIO_RF),
    5158                 :            :                                             true,
    5159                 :            :                                             &derived->declared_at);
    5160                 :            :     }
    5161                 :            :   else
    5162                 :            :     {
    5163                 :        217 :       if (write == true)
    5164                 :        102 :         tb_io_st = gfc_find_typebound_proc (derived, &t,
    5165                 :            :                                             gfc_code2string (dtio_procs,
    5166                 :            :                                                              DTIO_WUF),
    5167                 :            :                                             true,
    5168                 :            :                                             &derived->declared_at);
    5169                 :            :       else
    5170                 :        115 :         tb_io_st = gfc_find_typebound_proc (derived, &t,
    5171                 :            :                                             gfc_code2string (dtio_procs,
    5172                 :            :                                                              DTIO_RUF),
    5173                 :            :                                             true,
    5174                 :            :                                             &derived->declared_at);
    5175                 :            :     }
    5176                 :            :   return tb_io_st;
    5177                 :            : }
    5178                 :            : 
    5179                 :            : 
    5180                 :            : gfc_symbol *
    5181                 :       2704 : gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
    5182                 :            : {
    5183                 :       2704 :   gfc_symtree *tb_io_st = NULL;
    5184                 :       2704 :   gfc_symbol *dtio_sub = NULL;
    5185                 :       2704 :   gfc_symbol *extended;
    5186                 :       2704 :   gfc_typebound_proc *tb_io_proc, *specific_proc;
    5187                 :            : 
    5188                 :       2704 :   tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
    5189                 :            : 
    5190                 :       2704 :   if (tb_io_st != NULL)
    5191                 :            :     {
    5192                 :        780 :       const char *genname;
    5193                 :        780 :       gfc_symtree *st;
    5194                 :            : 
    5195                 :        780 :       tb_io_proc = tb_io_st->n.tb;
    5196                 :        780 :       gcc_assert (tb_io_proc != NULL);
    5197                 :        780 :       gcc_assert (tb_io_proc->is_generic);
    5198                 :        780 :       gcc_assert (tb_io_proc->u.generic->next == NULL);
    5199                 :            : 
    5200                 :        780 :       specific_proc = tb_io_proc->u.generic->specific;
    5201                 :        780 :       gcc_assert (!specific_proc->is_generic);
    5202                 :            : 
    5203                 :            :       /* Go back and make sure that we have the right specific procedure.
    5204                 :            :          Here we most likely have a procedure from the parent type, which
    5205                 :            :          can be overridden in extensions.  */
    5206                 :        780 :       genname = tb_io_proc->u.generic->specific_st->name;
    5207                 :        780 :       st = gfc_find_typebound_proc (derived, NULL, genname,
    5208                 :            :                                     true, &tb_io_proc->where);
    5209                 :        780 :       if (st)
    5210                 :        780 :         dtio_sub = st->n.tb->u.specific->n.sym;
    5211                 :            :       else
    5212                 :          0 :         dtio_sub = specific_proc->u.specific->n.sym;
    5213                 :            : 
    5214                 :        780 :       goto finish;
    5215                 :            :     }
    5216                 :            : 
    5217                 :            :   /* If there is not a typebound binding, look for a generic
    5218                 :            :      DTIO interface.  */
    5219                 :       3925 :   for (extended = derived; extended;
    5220                 :       2001 :        extended = gfc_get_derived_super_type (extended))
    5221                 :            :     {
    5222                 :       2001 :       if (extended == NULL || extended->ns == NULL
    5223                 :       2001 :           || extended->attr.flavor == FL_UNKNOWN)
    5224                 :            :         return NULL;
    5225                 :            : 
    5226                 :       2001 :       if (formatted == true)
    5227                 :            :         {
    5228                 :       1941 :           if (write == true)
    5229                 :        902 :             tb_io_st = gfc_find_symtree (extended->ns->sym_root,
    5230                 :            :                                          gfc_code2string (dtio_procs,
    5231                 :            :                                                           DTIO_WF));
    5232                 :            :           else
    5233                 :       1039 :             tb_io_st = gfc_find_symtree (extended->ns->sym_root,
    5234                 :            :                                          gfc_code2string (dtio_procs,
    5235                 :            :                                                           DTIO_RF));
    5236                 :            :         }
    5237                 :            :       else
    5238                 :            :         {
    5239                 :         60 :           if (write == true)
    5240                 :         24 :             tb_io_st = gfc_find_symtree (extended->ns->sym_root,
    5241                 :            :                                          gfc_code2string (dtio_procs,
    5242                 :            :                                                           DTIO_WUF));
    5243                 :            :           else
    5244                 :         36 :             tb_io_st = gfc_find_symtree (extended->ns->sym_root,
    5245                 :            :                                          gfc_code2string (dtio_procs,
    5246                 :            :                                                           DTIO_RUF));
    5247                 :            :         }
    5248                 :            : 
    5249                 :       2001 :       if (tb_io_st != NULL
    5250                 :        147 :           && tb_io_st->n.sym
    5251                 :        147 :           && tb_io_st->n.sym->generic)
    5252                 :            :         {
    5253                 :         26 :           for (gfc_interface *intr = tb_io_st->n.sym->generic;
    5254                 :        173 :                intr && intr->sym; intr = intr->next)
    5255                 :            :             {
    5256                 :        151 :               if (intr->sym->formal)
    5257                 :            :                 {
    5258                 :        146 :                   gfc_symbol *fsym = intr->sym->formal->sym;
    5259                 :        146 :                   if ((fsym->ts.type == BT_CLASS
    5260                 :         98 :                       && CLASS_DATA (fsym)->ts.u.derived == extended)
    5261                 :         69 :                       || (fsym->ts.type == BT_DERIVED
    5262                 :         48 :                           && fsym->ts.u.derived == extended))
    5263                 :            :                     {
    5264                 :            :                       dtio_sub = intr->sym;
    5265                 :            :                       break;
    5266                 :            :                     }
    5267                 :            :                 }
    5268                 :            :             }
    5269                 :            :         }
    5270                 :            :     }
    5271                 :            : 
    5272                 :       1924 : finish:
    5273                 :       2704 :   if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
    5274                 :        151 :     gfc_find_derived_vtab (derived);
    5275                 :            : 
    5276                 :            :   return dtio_sub;
    5277                 :            : }
    5278                 :            : 
    5279                 :            : /* Helper function - if we do not find an interface for a procedure,
    5280                 :            :    construct it from the actual arglist.  Luckily, this can only
    5281                 :            :    happen for call by reference, so the information we actually need
    5282                 :            :    to provide (and which would be impossible to guess from the call
    5283                 :            :    itself) is not actually needed.  */
    5284                 :            : 
    5285                 :            : void
    5286                 :       1680 : gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
    5287                 :            :                                     gfc_actual_arglist *actual_args)
    5288                 :            : {
    5289                 :       1680 :   gfc_actual_arglist *a;
    5290                 :       1680 :   gfc_formal_arglist **f;
    5291                 :       1680 :   gfc_symbol *s;
    5292                 :       1680 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    5293                 :       1680 :   static int var_num;
    5294                 :            : 
    5295                 :       1680 :   f = &sym->formal;
    5296                 :       5407 :   for (a = actual_args; a != NULL; a = a->next)
    5297                 :            :     {
    5298                 :       3727 :       (*f) = gfc_get_formal_arglist ();
    5299                 :       3727 :       if (a->expr)
    5300                 :            :         {
    5301                 :       3719 :           snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
    5302                 :       3719 :           gfc_get_symbol (name, gfc_current_ns, &s);
    5303                 :       3719 :           if (a->expr->ts.type == BT_PROCEDURE)
    5304                 :            :             {
    5305                 :         19 :               s->attr.flavor = FL_PROCEDURE;
    5306                 :            :             }
    5307                 :            :           else
    5308                 :            :             {
    5309                 :       3700 :               s->ts = a->expr->ts;
    5310                 :            : 
    5311                 :       3700 :               if (s->ts.type == BT_CHARACTER)
    5312                 :        144 :                 s->ts.u.cl = gfc_get_charlen ();
    5313                 :            : 
    5314                 :       3700 :               s->ts.deferred = 0;
    5315                 :       3700 :               s->ts.is_iso_c = 0;
    5316                 :       3700 :               s->ts.is_c_interop = 0;
    5317                 :       3700 :               s->attr.flavor = FL_VARIABLE;
    5318                 :       3700 :               s->attr.artificial = 1;
    5319                 :       3700 :               if (a->expr->rank > 0)
    5320                 :            :                 {
    5321                 :        777 :                   s->attr.dimension = 1;
    5322                 :        777 :                   s->as = gfc_get_array_spec ();
    5323                 :        777 :                   s->as->rank = 1;
    5324                 :       1554 :                   s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
    5325                 :        777 :                                                       &a->expr->where, 1);
    5326                 :        777 :                   s->as->upper[0] = NULL;
    5327                 :        777 :                   s->as->type = AS_ASSUMED_SIZE;
    5328                 :            :                 }
    5329                 :            :               else
    5330                 :       2923 :                 s->maybe_array = maybe_dummy_array_arg (a->expr);
    5331                 :            :             }
    5332                 :       3719 :           s->attr.dummy = 1;
    5333                 :       3719 :           s->declared_at = a->expr->where;
    5334                 :       3719 :           s->attr.intent = INTENT_UNKNOWN;
    5335                 :       3719 :           (*f)->sym = s;
    5336                 :            :         }
    5337                 :            :       else  /* If a->expr is NULL, this is an alternate rerturn.  */
    5338                 :          8 :         (*f)->sym = NULL;
    5339                 :            : 
    5340                 :       3727 :       f = &((*f)->next);
    5341                 :            :     }
    5342                 :       1680 : }

Generated by: LCOV version 1.0

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto --enable-host-shared. GCC test suite is run with the built compiler.