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

Generated by: LCOV version 2.0-1

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,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.