LCOV - code coverage report
Current view: top level - gcc/fortran - symbol.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 2010 2242 89.7 %
Date: 2020-03-28 11:57:23 Functions: 148 165 89.7 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Maintain binary trees of symbols.
       2                 :            :    Copyright (C) 2000-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Andy Vaught
       4                 :            : 
       5                 :            : This file is part of GCC.
       6                 :            : 
       7                 :            : GCC is free software; you can redistribute it and/or modify it under
       8                 :            : the terms of the GNU General Public License as published by the Free
       9                 :            : Software Foundation; either version 3, or (at your option) any later
      10                 :            : version.
      11                 :            : 
      12                 :            : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :            : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :            : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :            : for more details.
      16                 :            : 
      17                 :            : You should have received a copy of the GNU General Public License
      18                 :            : along with GCC; see the file COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */
      20                 :            : 
      21                 :            : 
      22                 :            : #include "config.h"
      23                 :            : #include "system.h"
      24                 :            : #include "coretypes.h"
      25                 :            : #include "options.h"
      26                 :            : #include "gfortran.h"
      27                 :            : #include "parse.h"
      28                 :            : #include "match.h"
      29                 :            : #include "constructor.h"
      30                 :            : 
      31                 :            : 
      32                 :            : /* Strings for all symbol attributes.  We use these for dumping the
      33                 :            :    parse tree, in error messages, and also when reading and writing
      34                 :            :    modules.  */
      35                 :            : 
      36                 :            : const mstring flavors[] =
      37                 :            : {
      38                 :            :   minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
      39                 :            :   minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
      40                 :            :   minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
      41                 :            :   minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
      42                 :            :   minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
      43                 :            :   minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT),
      44                 :            :   minit (NULL, -1)
      45                 :            : };
      46                 :            : 
      47                 :            : const mstring procedures[] =
      48                 :            : {
      49                 :            :     minit ("UNKNOWN-PROC", PROC_UNKNOWN),
      50                 :            :     minit ("MODULE-PROC", PROC_MODULE),
      51                 :            :     minit ("INTERNAL-PROC", PROC_INTERNAL),
      52                 :            :     minit ("DUMMY-PROC", PROC_DUMMY),
      53                 :            :     minit ("INTRINSIC-PROC", PROC_INTRINSIC),
      54                 :            :     minit ("EXTERNAL-PROC", PROC_EXTERNAL),
      55                 :            :     minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
      56                 :            :     minit (NULL, -1)
      57                 :            : };
      58                 :            : 
      59                 :            : const mstring intents[] =
      60                 :            : {
      61                 :            :     minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
      62                 :            :     minit ("IN", INTENT_IN),
      63                 :            :     minit ("OUT", INTENT_OUT),
      64                 :            :     minit ("INOUT", INTENT_INOUT),
      65                 :            :     minit (NULL, -1)
      66                 :            : };
      67                 :            : 
      68                 :            : const mstring access_types[] =
      69                 :            : {
      70                 :            :     minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
      71                 :            :     minit ("PUBLIC", ACCESS_PUBLIC),
      72                 :            :     minit ("PRIVATE", ACCESS_PRIVATE),
      73                 :            :     minit (NULL, -1)
      74                 :            : };
      75                 :            : 
      76                 :            : const mstring ifsrc_types[] =
      77                 :            : {
      78                 :            :     minit ("UNKNOWN", IFSRC_UNKNOWN),
      79                 :            :     minit ("DECL", IFSRC_DECL),
      80                 :            :     minit ("BODY", IFSRC_IFBODY)
      81                 :            : };
      82                 :            : 
      83                 :            : const mstring save_status[] =
      84                 :            : {
      85                 :            :     minit ("UNKNOWN", SAVE_NONE),
      86                 :            :     minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
      87                 :            :     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
      88                 :            : };
      89                 :            : 
      90                 :            : /* Set the mstrings for DTIO procedure names.  */
      91                 :            : const mstring dtio_procs[] =
      92                 :            : {
      93                 :            :     minit ("_dtio_formatted_read", DTIO_RF),
      94                 :            :     minit ("_dtio_formatted_write", DTIO_WF),
      95                 :            :     minit ("_dtio_unformatted_read", DTIO_RUF),
      96                 :            :     minit ("_dtio_unformatted_write", DTIO_WUF),
      97                 :            : };
      98                 :            : 
      99                 :            : /* This is to make sure the backend generates setup code in the correct
     100                 :            :    order.  */
     101                 :            : 
     102                 :            : static int next_dummy_order = 1;
     103                 :            : 
     104                 :            : 
     105                 :            : gfc_namespace *gfc_current_ns;
     106                 :            : gfc_namespace *gfc_global_ns_list;
     107                 :            : 
     108                 :            : gfc_gsymbol *gfc_gsym_root = NULL;
     109                 :            : 
     110                 :            : gfc_symbol *gfc_derived_types;
     111                 :            : 
     112                 :            : static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
     113                 :            : static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
     114                 :            : 
     115                 :            : 
     116                 :            : /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
     117                 :            : 
     118                 :            : /* The following static variable indicates whether a particular element has
     119                 :            :    been explicitly set or not.  */
     120                 :            : 
     121                 :            : static int new_flag[GFC_LETTERS];
     122                 :            : 
     123                 :            : 
     124                 :            : /* Handle a correctly parsed IMPLICIT NONE.  */
     125                 :            : 
     126                 :            : void
     127                 :      16104 : gfc_set_implicit_none (bool type, bool external, locus *loc)
     128                 :            : {
     129                 :      16104 :   int i;
     130                 :            : 
     131                 :      16104 :   if (external)
     132                 :        405 :     gfc_current_ns->has_implicit_none_export = 1;
     133                 :            : 
     134                 :      16104 :   if (type)
     135                 :            :     {
     136                 :      16094 :       gfc_current_ns->seen_implicit_none = 1;
     137                 :     434487 :       for (i = 0; i < GFC_LETTERS; i++)
     138                 :            :         {
     139                 :     418395 :           if (gfc_current_ns->set_flag[i])
     140                 :            :             {
     141                 :          2 :               gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
     142                 :            :                              "IMPLICIT statement", loc);
     143                 :          2 :               return;
     144                 :            :             }
     145                 :     418393 :           gfc_clear_ts (&gfc_current_ns->default_type[i]);
     146                 :     418393 :           gfc_current_ns->set_flag[i] = 1;
     147                 :            :         }
     148                 :            :     }
     149                 :            : }
     150                 :            : 
     151                 :            : 
     152                 :            : /* Reset the implicit range flags.  */
     153                 :            : 
     154                 :            : void
     155                 :      16729 : gfc_clear_new_implicit (void)
     156                 :            : {
     157                 :      16729 :   int i;
     158                 :            : 
     159                 :     451683 :   for (i = 0; i < GFC_LETTERS; i++)
     160                 :     434954 :     new_flag[i] = 0;
     161                 :      16729 : }
     162                 :            : 
     163                 :            : 
     164                 :            : /* Prepare for a new implicit range.  Sets flags in new_flag[].  */
     165                 :            : 
     166                 :            : bool
     167                 :        658 : gfc_add_new_implicit_range (int c1, int c2)
     168                 :            : {
     169                 :        658 :   int i;
     170                 :            : 
     171                 :        658 :   c1 -= 'a';
     172                 :        658 :   c2 -= 'a';
     173                 :            : 
     174                 :       6155 :   for (i = c1; i <= c2; i++)
     175                 :            :     {
     176                 :       5497 :       if (new_flag[i])
     177                 :            :         {
     178                 :          0 :           gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
     179                 :            :                      i + 'A');
     180                 :          0 :           return false;
     181                 :            :         }
     182                 :            : 
     183                 :       5497 :       new_flag[i] = 1;
     184                 :            :     }
     185                 :            : 
     186                 :            :   return true;
     187                 :            : }
     188                 :            : 
     189                 :            : 
     190                 :            : /* Add a matched implicit range for gfc_set_implicit().  Check if merging
     191                 :            :    the new implicit types back into the existing types will work.  */
     192                 :            : 
     193                 :            : bool
     194                 :        457 : gfc_merge_new_implicit (gfc_typespec *ts)
     195                 :            : {
     196                 :        457 :   int i;
     197                 :            : 
     198                 :        457 :   if (gfc_current_ns->seen_implicit_none)
     199                 :            :     {
     200                 :          0 :       gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
     201                 :          0 :       return false;
     202                 :            :     }
     203                 :            : 
     204                 :      12293 :   for (i = 0; i < GFC_LETTERS; i++)
     205                 :            :     {
     206                 :      11838 :       if (new_flag[i])
     207                 :            :         {
     208                 :       5459 :           if (gfc_current_ns->set_flag[i])
     209                 :            :             {
     210                 :          2 :               gfc_error ("Letter %qc already has an IMPLICIT type at %C",
     211                 :            :                          i + 'A');
     212                 :          2 :               return false;
     213                 :            :             }
     214                 :            : 
     215                 :       5457 :           gfc_current_ns->default_type[i] = *ts;
     216                 :       5457 :           gfc_current_ns->implicit_loc[i] = gfc_current_locus;
     217                 :       5457 :           gfc_current_ns->set_flag[i] = 1;
     218                 :            :         }
     219                 :            :     }
     220                 :            :   return true;
     221                 :            : }
     222                 :            : 
     223                 :            : 
     224                 :            : /* Given a symbol, return a pointer to the typespec for its default type.  */
     225                 :            : 
     226                 :            : gfc_typespec *
     227                 :    1906040 : gfc_get_default_type (const char *name, gfc_namespace *ns)
     228                 :            : {
     229                 :    1906040 :   char letter;
     230                 :            : 
     231                 :    1906040 :   letter = name[0];
     232                 :            : 
     233                 :    1906040 :   if (flag_allow_leading_underscore && letter == '_')
     234                 :          0 :     gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
     235                 :            :                      "gfortran developers, and should not be used for "
     236                 :            :                      "implicitly typed variables");
     237                 :            : 
     238                 :    1906040 :   if (letter < 'a' || letter > 'z')
     239                 :          0 :     gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);
     240                 :            : 
     241                 :    1906040 :   if (ns == NULL)
     242                 :     170221 :     ns = gfc_current_ns;
     243                 :            : 
     244                 :    1906040 :   return &ns->default_type[letter - 'a'];
     245                 :            : }
     246                 :            : 
     247                 :            : 
     248                 :            : /* Recursively append candidate SYM to CANDIDATES.  Store the number of
     249                 :            :    candidates in CANDIDATES_LEN.  */
     250                 :            : 
     251                 :            : static void
     252                 :        339 : lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
     253                 :            :                                      char **&candidates,
     254                 :            :                                      size_t &candidates_len)
     255                 :            : {
     256                 :        559 :   gfc_symtree *p;
     257                 :            : 
     258                 :        559 :   if (sym == NULL)
     259                 :            :     return;
     260                 :            : 
     261                 :        559 :   if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
     262                 :        283 :     vec_push (candidates, candidates_len, sym->name);
     263                 :        559 :   p = sym->left;
     264                 :        559 :   if (p)
     265                 :        259 :     lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
     266                 :            : 
     267                 :        559 :   p = sym->right;
     268                 :        559 :   if (p)
     269                 :            :     lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
     270                 :            : }
     271                 :            : 
     272                 :            : 
     273                 :            : /* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account.  */
     274                 :            : 
     275                 :            : static const char*
     276                 :         80 : lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
     277                 :            : {
     278                 :         80 :   char **candidates = NULL;
     279                 :         80 :   size_t candidates_len = 0;
     280                 :         80 :   lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
     281                 :            :                                        candidates_len);
     282                 :         80 :   return gfc_closest_fuzzy_match (sym_name, candidates);
     283                 :            : }
     284                 :            : 
     285                 :            : 
     286                 :            : /* Given a pointer to a symbol, set its type according to the first
     287                 :            :    letter of its name.  Fails if the letter in question has no default
     288                 :            :    type.  */
     289                 :            : 
     290                 :            : bool
     291                 :      73571 : gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
     292                 :            : {
     293                 :      73571 :   gfc_typespec *ts;
     294                 :            : 
     295                 :      73571 :   if (sym->ts.type != BT_UNKNOWN)
     296                 :          0 :     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
     297                 :            : 
     298                 :      73571 :   ts = gfc_get_default_type (sym->name, ns);
     299                 :            : 
     300                 :      73571 :   if (ts->type == BT_UNKNOWN)
     301                 :            :     {
     302                 :      30938 :       if (error_flag && !sym->attr.untyped)
     303                 :            :         {
     304                 :         80 :           const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
     305                 :         80 :           if (guessed)
     306                 :         11 :             gfc_error ("Symbol %qs at %L has no IMPLICIT type"
     307                 :            :                        "; did you mean %qs?",
     308                 :            :                        sym->name, &sym->declared_at, guessed);
     309                 :            :           else
     310                 :         69 :             gfc_error ("Symbol %qs at %L has no IMPLICIT type",
     311                 :            :                        sym->name, &sym->declared_at);
     312                 :         80 :           sym->attr.untyped = 1; /* Ensure we only give an error once.  */
     313                 :            :         }
     314                 :            : 
     315                 :      30938 :       return false;
     316                 :            :     }
     317                 :            : 
     318                 :      42633 :   sym->ts = *ts;
     319                 :      42633 :   sym->attr.implicit_type = 1;
     320                 :            : 
     321                 :      42633 :   if (ts->type == BT_CHARACTER && ts->u.cl)
     322                 :        456 :     sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
     323                 :      42177 :   else if (ts->type == BT_CLASS
     324                 :      42177 :            && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
     325                 :            :     return false;
     326                 :            : 
     327                 :      42633 :   if (sym->attr.is_bind_c == 1 && warn_c_binding_type)
     328                 :            :     {
     329                 :            :       /* BIND(C) variables should not be implicitly declared.  */
     330                 :          1 :       gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) "
     331                 :            :                        "variable %qs at %L may not be C interoperable",
     332                 :            :                        sym->name, &sym->declared_at);
     333                 :          1 :       sym->ts.f90_type = sym->ts.type;
     334                 :            :     }
     335                 :            : 
     336                 :      42633 :   if (sym->attr.dummy != 0)
     337                 :            :     {
     338                 :       4189 :       if (sym->ns->proc_name != NULL
     339                 :       4189 :           && (sym->ns->proc_name->attr.subroutine != 0
     340                 :       4189 :               || sym->ns->proc_name->attr.function != 0)
     341                 :       4189 :           && sym->ns->proc_name->attr.is_bind_c != 0
     342                 :         54 :           && warn_c_binding_type)
     343                 :            :         {
     344                 :            :           /* Dummy args to a BIND(C) routine may not be interoperable if
     345                 :            :              they are implicitly typed.  */
     346                 :          1 :           gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable "
     347                 :            :                            "%qs at %L may not be C interoperable but it is a "
     348                 :            :                            "dummy argument to the BIND(C) procedure %qs at %L",
     349                 :            :                            sym->name, &(sym->declared_at),
     350                 :            :                            sym->ns->proc_name->name,
     351                 :            :                            &(sym->ns->proc_name->declared_at));
     352                 :          1 :           sym->ts.f90_type = sym->ts.type;
     353                 :            :         }
     354                 :            :     }
     355                 :            : 
     356                 :            :   return true;
     357                 :            : }
     358                 :            : 
     359                 :            : 
     360                 :            : /* This function is called from parse.c(parse_progunit) to check the
     361                 :            :    type of the function is not implicitly typed in the host namespace
     362                 :            :    and to implicitly type the function result, if necessary.  */
     363                 :            : 
     364                 :            : void
     365                 :       9517 : gfc_check_function_type (gfc_namespace *ns)
     366                 :            : {
     367                 :       9517 :   gfc_symbol *proc = ns->proc_name;
     368                 :            : 
     369                 :       9517 :   if (!proc->attr.contained || proc->result->attr.implicit_type)
     370                 :            :     return;
     371                 :            : 
     372                 :       7031 :   if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
     373                 :            :     {
     374                 :         99 :       if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
     375                 :            :         {
     376                 :         79 :           if (proc->result != proc)
     377                 :            :             {
     378                 :         15 :               proc->ts = proc->result->ts;
     379                 :         15 :               proc->as = gfc_copy_array_spec (proc->result->as);
     380                 :         15 :               proc->attr.dimension = proc->result->attr.dimension;
     381                 :         15 :               proc->attr.pointer = proc->result->attr.pointer;
     382                 :         15 :               proc->attr.allocatable = proc->result->attr.allocatable;
     383                 :            :             }
     384                 :            :         }
     385                 :         20 :       else if (!proc->result->attr.proc_pointer)
     386                 :            :         {
     387                 :          2 :           gfc_error ("Function result %qs at %L has no IMPLICIT type",
     388                 :            :                      proc->result->name, &proc->result->declared_at);
     389                 :          2 :           proc->result->attr.untyped = 1;
     390                 :            :         }
     391                 :            :     }
     392                 :            : }
     393                 :            : 
     394                 :            : 
     395                 :            : /******************** Symbol attribute stuff *********************/
     396                 :            : 
     397                 :            : /* This is a generic conflict-checker.  We do this to avoid having a
     398                 :            :    single conflict in two places.  */
     399                 :            : 
     400                 :            : #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
     401                 :            : #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
     402                 :            : #define conf_std(a, b, std) if (attr->a && attr->b)\
     403                 :            :                               {\
     404                 :            :                                 a1 = a;\
     405                 :            :                                 a2 = b;\
     406                 :            :                                 standard = std;\
     407                 :            :                                 goto conflict_std;\
     408                 :            :                               }
     409                 :            : 
     410                 :            : bool
     411                 :    4552490 : gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
     412                 :            : {
     413                 :    4552490 :   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
     414                 :            :     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
     415                 :            :     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
     416                 :            :     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
     417                 :            :     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
     418                 :            :     *privat = "PRIVATE", *recursive = "RECURSIVE",
     419                 :            :     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
     420                 :            :     *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
     421                 :            :     *function = "FUNCTION", *subroutine = "SUBROUTINE",
     422                 :            :     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
     423                 :            :     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
     424                 :            :     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     425                 :            :     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
     426                 :            :     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
     427                 :            :     *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
     428                 :            :     *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
     429                 :            :     *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
     430                 :            :     *pdt_len = "LEN", *pdt_kind = "KIND";
     431                 :    4552490 :   static const char *threadprivate = "THREADPRIVATE";
     432                 :    4552490 :   static const char *omp_declare_target = "OMP DECLARE TARGET";
     433                 :    4552490 :   static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
     434                 :    4552490 :   static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
     435                 :    4552490 :   static const char *oacc_declare_create = "OACC DECLARE CREATE";
     436                 :    4552490 :   static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
     437                 :    4552490 :   static const char *oacc_declare_device_resident =
     438                 :            :                                                 "OACC DECLARE DEVICE_RESIDENT";
     439                 :            : 
     440                 :    4552490 :   const char *a1, *a2;
     441                 :    4552490 :   int standard;
     442                 :            : 
     443                 :    4552490 :   if (attr->artificial)
     444                 :            :     return true;
     445                 :            : 
     446                 :    4552480 :   if (where == NULL)
     447                 :    2971880 :     where = &gfc_current_locus;
     448                 :            : 
     449                 :    4552480 :   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
     450                 :            :     {
     451                 :       1019 :       a1 = pointer;
     452                 :       1019 :       a2 = intent;
     453                 :       1019 :       standard = GFC_STD_F2003;
     454                 :       1019 :       goto conflict_std;
     455                 :            :     }
     456                 :            : 
     457                 :    4551460 :   if (attr->in_namelist && (attr->allocatable || attr->pointer))
     458                 :            :     {
     459                 :        613 :       a1 = in_namelist;
     460                 :        613 :       a2 = attr->allocatable ? allocatable : pointer;
     461                 :        613 :       standard = GFC_STD_F2003;
     462                 :        613 :       goto conflict_std;
     463                 :            :     }
     464                 :            : 
     465                 :            :   /* Check for attributes not allowed in a BLOCK DATA.  */
     466                 :    4550850 :   if (gfc_current_state () == COMP_BLOCK_DATA)
     467                 :            :     {
     468                 :       2683 :       a1 = NULL;
     469                 :            : 
     470                 :       2683 :       if (attr->in_namelist)
     471                 :          1 :         a1 = in_namelist;
     472                 :       2683 :       if (attr->allocatable)
     473                 :          0 :         a1 = allocatable;
     474                 :       2683 :       if (attr->external)
     475                 :          0 :         a1 = external;
     476                 :       2683 :       if (attr->optional)
     477                 :          0 :         a1 = optional;
     478                 :       2683 :       if (attr->access == ACCESS_PRIVATE)
     479                 :          0 :         a1 = privat;
     480                 :       2683 :       if (attr->access == ACCESS_PUBLIC)
     481                 :          0 :         a1 = publik;
     482                 :       2683 :       if (attr->intent != INTENT_UNKNOWN)
     483                 :          0 :         a1 = intent;
     484                 :            : 
     485                 :       2683 :       if (a1 != NULL)
     486                 :            :         {
     487                 :          1 :           gfc_error
     488                 :          1 :             ("%s attribute not allowed in BLOCK DATA program unit at %L",
     489                 :            :              a1, where);
     490                 :          1 :           return false;
     491                 :            :         }
     492                 :            :     }
     493                 :            : 
     494                 :    4550850 :   if (attr->save == SAVE_EXPLICIT)
     495                 :            :     {
     496                 :       5769 :       conf (dummy, save);
     497                 :       5767 :       conf (in_common, save);
     498                 :       5759 :       conf (result, save);
     499                 :       5756 :       conf (automatic, save);
     500                 :            : 
     501                 :       5754 :       switch (attr->flavor)
     502                 :            :         {
     503                 :          2 :           case FL_PROGRAM:
     504                 :          2 :           case FL_BLOCK_DATA:
     505                 :          2 :           case FL_MODULE:
     506                 :          2 :           case FL_LABEL:
     507                 :          2 :           case_fl_struct:
     508                 :          2 :           case FL_PARAMETER:
     509                 :          2 :             a1 = gfc_code2string (flavors, attr->flavor);
     510                 :          2 :             a2 = save;
     511                 :          2 :             goto conflict;
     512                 :          2 :           case FL_NAMELIST:
     513                 :          2 :             gfc_error ("Namelist group name at %L cannot have the "
     514                 :            :                        "SAVE attribute", where);
     515                 :          2 :             return false;
     516                 :            :           case FL_PROCEDURE:
     517                 :            :             /* Conflicts between SAVE and PROCEDURE will be checked at
     518                 :            :                resolution stage, see "resolve_fl_procedure".  */
     519                 :            :           case FL_VARIABLE:
     520                 :            :           default:
     521                 :            :             break;
     522                 :            :         }
     523                 :            :     }
     524                 :            : 
     525                 :            :   /* The copying of procedure dummy arguments for module procedures in
     526                 :            :      a submodule occur whilst the current state is COMP_CONTAINS. It
     527                 :            :      is necessary, therefore, to let this through.  */
     528                 :    4550830 :   if (name && attr->dummy
     529                 :     164012 :       && (attr->function || attr->subroutine)
     530                 :       1591 :       && gfc_current_state () == COMP_CONTAINS
     531                 :         10 :       && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
     532                 :          3 :     gfc_error_now ("internal procedure %qs at %L conflicts with "
     533                 :            :                    "DUMMY argument", name, where);
     534                 :            : 
     535                 :    4550830 :   conf (dummy, entry);
     536                 :    4550830 :   conf (dummy, intrinsic);
     537                 :    4550830 :   conf (dummy, threadprivate);
     538                 :    4550830 :   conf (dummy, omp_declare_target);
     539                 :    4550830 :   conf (dummy, omp_declare_target_link);
     540                 :    4550830 :   conf (pointer, target);
     541                 :    4550830 :   conf (pointer, intrinsic);
     542                 :    4550830 :   conf (pointer, elemental);
     543                 :    4550820 :   conf (pointer, codimension);
     544                 :    4550810 :   conf (allocatable, elemental);
     545                 :            : 
     546                 :    4550800 :   conf (in_common, automatic);
     547                 :    4550800 :   conf (result, automatic);
     548                 :    4550800 :   conf (use_assoc, automatic);
     549                 :    4550800 :   conf (dummy, automatic);
     550                 :            : 
     551                 :    4550800 :   conf (target, external);
     552                 :    4550800 :   conf (target, intrinsic);
     553                 :            : 
     554                 :    4550800 :   if (!attr->if_source)
     555                 :    4490200 :     conf (external, dimension);   /* See Fortran 95's R504.  */
     556                 :            : 
     557                 :    4550800 :   conf (external, intrinsic);
     558                 :    4550790 :   conf (entry, intrinsic);
     559                 :    4550790 :   conf (abstract, intrinsic);
     560                 :            : 
     561                 :    4550790 :   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
     562                 :      51394 :     conf (external, subroutine);
     563                 :            : 
     564                 :      10045 :   if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
     565                 :    4550790 :                                              "Procedure pointer at %C"))
     566                 :            :     return false;
     567                 :            : 
     568                 :    4550780 :   conf (allocatable, pointer);
     569                 :    4550780 :   conf_std (allocatable, dummy, GFC_STD_F2003);
     570                 :    4545000 :   conf_std (allocatable, function, GFC_STD_F2003);
     571                 :    4544460 :   conf_std (allocatable, result, GFC_STD_F2003);
     572                 :    4543620 :   conf (elemental, recursive);
     573                 :            : 
     574                 :    4543620 :   conf (in_common, dummy);
     575                 :    4543620 :   conf (in_common, allocatable);
     576                 :    4543620 :   conf (in_common, codimension);
     577                 :    4543620 :   conf (in_common, result);
     578                 :            : 
     579                 :    4543620 :   conf (in_equivalence, use_assoc);
     580                 :    4543620 :   conf (in_equivalence, codimension);
     581                 :    4543620 :   conf (in_equivalence, dummy);
     582                 :    4543620 :   conf (in_equivalence, target);
     583                 :    4543620 :   conf (in_equivalence, pointer);
     584                 :    4543620 :   conf (in_equivalence, function);
     585                 :    4543620 :   conf (in_equivalence, result);
     586                 :    4543620 :   conf (in_equivalence, entry);
     587                 :    4543620 :   conf (in_equivalence, allocatable);
     588                 :    4543620 :   conf (in_equivalence, threadprivate);
     589                 :    4543620 :   conf (in_equivalence, omp_declare_target);
     590                 :    4543620 :   conf (in_equivalence, omp_declare_target_link);
     591                 :    4543620 :   conf (in_equivalence, oacc_declare_create);
     592                 :    4543620 :   conf (in_equivalence, oacc_declare_copyin);
     593                 :    4543620 :   conf (in_equivalence, oacc_declare_deviceptr);
     594                 :    4543620 :   conf (in_equivalence, oacc_declare_device_resident);
     595                 :    4543620 :   conf (in_equivalence, is_bind_c);
     596                 :            : 
     597                 :    4543610 :   conf (dummy, result);
     598                 :    4543610 :   conf (entry, result);
     599                 :    4543610 :   conf (generic, result);
     600                 :    4543610 :   conf (generic, omp_declare_target);
     601                 :    4543610 :   conf (generic, omp_declare_target_link);
     602                 :            : 
     603                 :    4543610 :   conf (function, subroutine);
     604                 :            : 
     605                 :    4543600 :   if (!function && !subroutine)
     606                 :          0 :     conf (is_bind_c, dummy);
     607                 :            : 
     608                 :    4543600 :   conf (is_bind_c, cray_pointer);
     609                 :    4543600 :   conf (is_bind_c, cray_pointee);
     610                 :    4543600 :   conf (is_bind_c, codimension);
     611                 :    4543600 :   conf (is_bind_c, allocatable);
     612                 :    4543600 :   conf (is_bind_c, elemental);
     613                 :            : 
     614                 :            :   /* Need to also get volatile attr, according to 5.1 of F2003 draft.
     615                 :            :      Parameter conflict caught below.  Also, value cannot be specified
     616                 :            :      for a dummy procedure.  */
     617                 :            : 
     618                 :            :   /* Cray pointer/pointee conflicts.  */
     619                 :    4543600 :   conf (cray_pointer, cray_pointee);
     620                 :    4543600 :   conf (cray_pointer, dimension);
     621                 :    4543600 :   conf (cray_pointer, codimension);
     622                 :    4543600 :   conf (cray_pointer, contiguous);
     623                 :    4543600 :   conf (cray_pointer, pointer);
     624                 :    4543600 :   conf (cray_pointer, target);
     625                 :    4543600 :   conf (cray_pointer, allocatable);
     626                 :    4543600 :   conf (cray_pointer, external);
     627                 :    4543600 :   conf (cray_pointer, intrinsic);
     628                 :    4543600 :   conf (cray_pointer, in_namelist);
     629                 :    4543600 :   conf (cray_pointer, function);
     630                 :    4543600 :   conf (cray_pointer, subroutine);
     631                 :    4543600 :   conf (cray_pointer, entry);
     632                 :            : 
     633                 :    4543600 :   conf (cray_pointee, allocatable);
     634                 :    4543600 :   conf (cray_pointee, contiguous);
     635                 :    4543600 :   conf (cray_pointee, codimension);
     636                 :    4543600 :   conf (cray_pointee, intent);
     637                 :    4543600 :   conf (cray_pointee, optional);
     638                 :    4543600 :   conf (cray_pointee, dummy);
     639                 :    4543600 :   conf (cray_pointee, target);
     640                 :    4543590 :   conf (cray_pointee, intrinsic);
     641                 :    4543590 :   conf (cray_pointee, pointer);
     642                 :    4543590 :   conf (cray_pointee, entry);
     643                 :    4543590 :   conf (cray_pointee, in_common);
     644                 :    4543590 :   conf (cray_pointee, in_equivalence);
     645                 :    4543590 :   conf (cray_pointee, threadprivate);
     646                 :    4543590 :   conf (cray_pointee, omp_declare_target);
     647                 :    4543590 :   conf (cray_pointee, omp_declare_target_link);
     648                 :    4543590 :   conf (cray_pointee, oacc_declare_create);
     649                 :    4543590 :   conf (cray_pointee, oacc_declare_copyin);
     650                 :    4543590 :   conf (cray_pointee, oacc_declare_deviceptr);
     651                 :    4543590 :   conf (cray_pointee, oacc_declare_device_resident);
     652                 :            : 
     653                 :    4543590 :   conf (data, dummy);
     654                 :    4543580 :   conf (data, function);
     655                 :    4543580 :   conf (data, result);
     656                 :    4543580 :   conf (data, allocatable);
     657                 :            : 
     658                 :    4543580 :   conf (value, pointer)
     659                 :    4543580 :   conf (value, allocatable)
     660                 :    4543580 :   conf (value, subroutine)
     661                 :    4543580 :   conf (value, function)
     662                 :    4543580 :   conf (value, volatile_)
     663                 :    4543580 :   conf (value, dimension)
     664                 :    4543580 :   conf (value, codimension)
     665                 :    4543580 :   conf (value, external)
     666                 :            : 
     667                 :    4543580 :   conf (codimension, result)
     668                 :            : 
     669                 :    4543570 :   if (attr->value
     670                 :    4543570 :       && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
     671                 :            :     {
     672                 :          4 :       a1 = value;
     673                 :          4 :       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
     674                 :          4 :       goto conflict;
     675                 :            :     }
     676                 :            : 
     677                 :    4543570 :   conf (is_protected, intrinsic)
     678                 :    4543570 :   conf (is_protected, in_common)
     679                 :            : 
     680                 :    4543560 :   conf (asynchronous, intrinsic)
     681                 :    4543560 :   conf (asynchronous, external)
     682                 :            : 
     683                 :    4543560 :   conf (volatile_, intrinsic)
     684                 :    4543560 :   conf (volatile_, external)
     685                 :            : 
     686                 :    4543560 :   if (attr->volatile_ && attr->intent == INTENT_IN)
     687                 :            :     {
     688                 :          1 :       a1 = volatile_;
     689                 :          1 :       a2 = intent_in;
     690                 :          1 :       goto conflict;
     691                 :            :     }
     692                 :            : 
     693                 :    4543560 :   conf (procedure, allocatable)
     694                 :    4543560 :   conf (procedure, dimension)
     695                 :    4543560 :   conf (procedure, codimension)
     696                 :    4543560 :   conf (procedure, intrinsic)
     697                 :    4543560 :   conf (procedure, target)
     698                 :    4543560 :   conf (procedure, value)
     699                 :    4543560 :   conf (procedure, volatile_)
     700                 :    4543560 :   conf (procedure, asynchronous)
     701                 :    4543560 :   conf (procedure, entry)
     702                 :            : 
     703                 :    4543560 :   conf (proc_pointer, abstract)
     704                 :    4543560 :   conf (proc_pointer, omp_declare_target)
     705                 :    4543560 :   conf (proc_pointer, omp_declare_target_link)
     706                 :            : 
     707                 :    4543560 :   conf (entry, omp_declare_target)
     708                 :    4543560 :   conf (entry, omp_declare_target_link)
     709                 :    4543560 :   conf (entry, oacc_declare_create)
     710                 :    4543560 :   conf (entry, oacc_declare_copyin)
     711                 :    4543560 :   conf (entry, oacc_declare_deviceptr)
     712                 :    4543560 :   conf (entry, oacc_declare_device_resident)
     713                 :            : 
     714                 :    4543560 :   conf (pdt_kind, allocatable)
     715                 :    4543560 :   conf (pdt_kind, pointer)
     716                 :    4543560 :   conf (pdt_kind, dimension)
     717                 :    4543550 :   conf (pdt_kind, codimension)
     718                 :            : 
     719                 :    4543550 :   conf (pdt_len, allocatable)
     720                 :    4543550 :   conf (pdt_len, pointer)
     721                 :    4543550 :   conf (pdt_len, dimension)
     722                 :    4543550 :   conf (pdt_len, codimension)
     723                 :            : 
     724                 :    4543550 :   if (attr->access == ACCESS_PRIVATE)
     725                 :            :     {
     726                 :       7940 :       a1 = privat;
     727                 :       7940 :       conf2 (pdt_kind);
     728                 :       7939 :       conf2 (pdt_len);
     729                 :            :     }
     730                 :            : 
     731                 :    4543550 :   a1 = gfc_code2string (flavors, attr->flavor);
     732                 :            : 
     733                 :    4543550 :   if (attr->in_namelist
     734                 :    4543550 :       && attr->flavor != FL_VARIABLE
     735                 :       1577 :       && attr->flavor != FL_PROCEDURE
     736                 :       1568 :       && attr->flavor != FL_UNKNOWN)
     737                 :            :     {
     738                 :          0 :       a2 = in_namelist;
     739                 :          0 :       goto conflict;
     740                 :            :     }
     741                 :            : 
     742                 :    4543550 :   switch (attr->flavor)
     743                 :            :     {
     744                 :     104579 :     case FL_PROGRAM:
     745                 :     104579 :     case FL_BLOCK_DATA:
     746                 :     104579 :     case FL_MODULE:
     747                 :     104579 :     case FL_LABEL:
     748                 :     104579 :       conf2 (codimension);
     749                 :     104579 :       conf2 (dimension);
     750                 :     104578 :       conf2 (dummy);
     751                 :     104578 :       conf2 (volatile_);
     752                 :     104576 :       conf2 (asynchronous);
     753                 :     104575 :       conf2 (contiguous);
     754                 :     104575 :       conf2 (pointer);
     755                 :     104575 :       conf2 (is_protected);
     756                 :     104574 :       conf2 (target);
     757                 :     104574 :       conf2 (external);
     758                 :     104573 :       conf2 (intrinsic);
     759                 :     104573 :       conf2 (allocatable);
     760                 :     104573 :       conf2 (result);
     761                 :     104573 :       conf2 (in_namelist);
     762                 :     104573 :       conf2 (optional);
     763                 :     104573 :       conf2 (function);
     764                 :     104573 :       conf2 (subroutine);
     765                 :     104572 :       conf2 (threadprivate);
     766                 :     104572 :       conf2 (omp_declare_target);
     767                 :     104572 :       conf2 (omp_declare_target_link);
     768                 :     104572 :       conf2 (oacc_declare_create);
     769                 :     104572 :       conf2 (oacc_declare_copyin);
     770                 :     104572 :       conf2 (oacc_declare_deviceptr);
     771                 :     104572 :       conf2 (oacc_declare_device_resident);
     772                 :            : 
     773                 :     104572 :       if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
     774                 :            :         {
     775                 :          2 :           a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
     776                 :          2 :           gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
     777                 :            :             name, where);
     778                 :          2 :           return false;
     779                 :            :         }
     780                 :            : 
     781                 :     104570 :       if (attr->is_bind_c)
     782                 :            :         {
     783                 :          2 :           gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
     784                 :          2 :           return false;
     785                 :            :         }
     786                 :            : 
     787                 :            :       break;
     788                 :            : 
     789                 :            :     case FL_VARIABLE:
     790                 :            :       break;
     791                 :            : 
     792                 :        702 :     case FL_NAMELIST:
     793                 :        702 :       conf2 (result);
     794                 :            :       break;
     795                 :            : 
     796                 :    2844070 :     case FL_PROCEDURE:
     797                 :            :       /* Conflicts with INTENT, SAVE and RESULT will be checked
     798                 :            :          at resolution stage, see "resolve_fl_procedure".  */
     799                 :            : 
     800                 :    2844070 :       if (attr->subroutine)
     801                 :            :         {
     802                 :      65136 :           a1 = subroutine;
     803                 :      65136 :           conf2 (target);
     804                 :      65136 :           conf2 (allocatable);
     805                 :      65136 :           conf2 (volatile_);
     806                 :      65135 :           conf2 (asynchronous);
     807                 :      65134 :           conf2 (in_namelist);
     808                 :      65134 :           conf2 (codimension);
     809                 :      65134 :           conf2 (dimension);
     810                 :      65133 :           conf2 (function);
     811                 :      65133 :           if (!attr->proc_pointer)
     812                 :      64926 :             conf2 (threadprivate);
     813                 :            :         }
     814                 :            : 
     815                 :            :       /* Procedure pointers in COMMON blocks are allowed in F03,
     816                 :            :        * but forbidden per F08:C5100.  */
     817                 :    2844070 :       if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008))
     818                 :    2843840 :         conf2 (in_common);
     819                 :            : 
     820                 :    2844060 :       conf2 (omp_declare_target_link);
     821                 :            : 
     822                 :    2844060 :       switch (attr->proc)
     823                 :            :         {
     824                 :     564441 :         case PROC_ST_FUNCTION:
     825                 :     564441 :           conf2 (dummy);
     826                 :     564440 :           conf2 (target);
     827                 :            :           break;
     828                 :            : 
     829                 :      32623 :         case PROC_MODULE:
     830                 :      32623 :           conf2 (dummy);
     831                 :            :           break;
     832                 :            : 
     833                 :          0 :         case PROC_DUMMY:
     834                 :          0 :           conf2 (result);
     835                 :          0 :           conf2 (threadprivate);
     836                 :            :           break;
     837                 :            : 
     838                 :            :         default:
     839                 :            :           break;
     840                 :            :         }
     841                 :            : 
     842                 :            :       break;
     843                 :            : 
     844                 :      24128 :     case_fl_struct:
     845                 :      24128 :       conf2 (dummy);
     846                 :      24128 :       conf2 (pointer);
     847                 :      24128 :       conf2 (target);
     848                 :      24128 :       conf2 (external);
     849                 :      24128 :       conf2 (intrinsic);
     850                 :      24128 :       conf2 (allocatable);
     851                 :      24128 :       conf2 (optional);
     852                 :      24128 :       conf2 (entry);
     853                 :      24128 :       conf2 (function);
     854                 :      24128 :       conf2 (subroutine);
     855                 :      24128 :       conf2 (threadprivate);
     856                 :      24128 :       conf2 (result);
     857                 :      24128 :       conf2 (omp_declare_target);
     858                 :      24128 :       conf2 (omp_declare_target_link);
     859                 :      24128 :       conf2 (oacc_declare_create);
     860                 :      24128 :       conf2 (oacc_declare_copyin);
     861                 :      24128 :       conf2 (oacc_declare_deviceptr);
     862                 :      24128 :       conf2 (oacc_declare_device_resident);
     863                 :            : 
     864                 :      24128 :       if (attr->intent != INTENT_UNKNOWN)
     865                 :            :         {
     866                 :          0 :           a2 = intent;
     867                 :          0 :           goto conflict;
     868                 :            :         }
     869                 :            :       break;
     870                 :            : 
     871                 :      24311 :     case FL_PARAMETER:
     872                 :      24311 :       conf2 (external);
     873                 :      24311 :       conf2 (intrinsic);
     874                 :      24311 :       conf2 (optional);
     875                 :      24311 :       conf2 (allocatable);
     876                 :      24311 :       conf2 (function);
     877                 :      24311 :       conf2 (subroutine);
     878                 :      24311 :       conf2 (entry);
     879                 :      24311 :       conf2 (contiguous);
     880                 :      24311 :       conf2 (pointer);
     881                 :      24311 :       conf2 (is_protected);
     882                 :      24311 :       conf2 (target);
     883                 :      24311 :       conf2 (dummy);
     884                 :      24311 :       conf2 (in_common);
     885                 :      24311 :       conf2 (value);
     886                 :      24310 :       conf2 (volatile_);
     887                 :      24309 :       conf2 (asynchronous);
     888                 :      24309 :       conf2 (threadprivate);
     889                 :      24309 :       conf2 (value);
     890                 :      24309 :       conf2 (codimension);
     891                 :      24308 :       conf2 (result);
     892                 :      24307 :       if (!attr->is_iso_c)
     893                 :      24299 :         conf2 (is_bind_c);
     894                 :            :       break;
     895                 :            : 
     896                 :            :     default:
     897                 :            :       break;
     898                 :            :     }
     899                 :            : 
     900                 :            :   return true;
     901                 :            : 
     902                 :        152 : conflict:
     903                 :        152 :   if (name == NULL)
     904                 :         54 :     gfc_error ("%s attribute conflicts with %s attribute at %L",
     905                 :            :                a1, a2, where);
     906                 :            :   else
     907                 :         98 :     gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
     908                 :            :                a1, a2, name, where);
     909                 :            : 
     910                 :            :   return false;
     911                 :            : 
     912                 :       8797 : conflict_std:
     913                 :       8797 :   if (name == NULL)
     914                 :            :     {
     915                 :       5359 :       return gfc_notify_std (standard, "%s attribute conflicts "
     916                 :            :                              "with %s attribute at %L", a1, a2,
     917                 :       5359 :                              where);
     918                 :            :     }
     919                 :            :   else
     920                 :            :     {
     921                 :       3438 :       return gfc_notify_std (standard, "%s attribute conflicts "
     922                 :            :                              "with %s attribute in %qs at %L",
     923                 :       3438 :                              a1, a2, name, where);
     924                 :            :     }
     925                 :            : }
     926                 :            : 
     927                 :            : #undef conf
     928                 :            : #undef conf2
     929                 :            : #undef conf_std
     930                 :            : 
     931                 :            : 
     932                 :            : /* Mark a symbol as referenced.  */
     933                 :            : 
     934                 :            : void
     935                 :    4948560 : gfc_set_sym_referenced (gfc_symbol *sym)
     936                 :            : {
     937                 :            : 
     938                 :    4948560 :   if (sym->attr.referenced)
     939                 :            :     return;
     940                 :            : 
     941                 :    2697110 :   sym->attr.referenced = 1;
     942                 :            : 
     943                 :            :   /* Remember which order dummy variables are accessed in.  */
     944                 :    2697110 :   if (sym->attr.dummy)
     945                 :      88965 :     sym->dummy_order = next_dummy_order++;
     946                 :            : }
     947                 :            : 
     948                 :            : 
     949                 :            : /* Common subroutine called by attribute changing subroutines in order
     950                 :            :    to prevent them from changing a symbol that has been
     951                 :            :    use-associated.  Returns zero if it is OK to change the symbol,
     952                 :            :    nonzero if not.  */
     953                 :            : 
     954                 :            : static int
     955                 :    1511410 : check_used (symbol_attribute *attr, const char *name, locus *where)
     956                 :            : {
     957                 :            : 
     958                 :    1383000 :   if (attr->use_assoc == 0)
     959                 :            :     return 0;
     960                 :            : 
     961                 :         36 :   if (where == NULL)
     962                 :         31 :     where = &gfc_current_locus;
     963                 :            : 
     964                 :         33 :   if (name == NULL)
     965                 :          0 :     gfc_error ("Cannot change attributes of USE-associated symbol at %L",
     966                 :            :                where);
     967                 :            :   else
     968                 :         33 :     gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
     969                 :            :                name, where);
     970                 :            : 
     971                 :            :   return 1;
     972                 :            : }
     973                 :            : 
     974                 :            : 
     975                 :            : /* Generate an error because of a duplicate attribute.  */
     976                 :            : 
     977                 :            : static void
     978                 :         11 : duplicate_attr (const char *attr, locus *where)
     979                 :            : {
     980                 :            : 
     981                 :          0 :   if (where == NULL)
     982                 :          7 :     where = &gfc_current_locus;
     983                 :            : 
     984                 :          0 :   gfc_error ("Duplicate %s attribute specified at %L", attr, where);
     985                 :          0 : }
     986                 :            : 
     987                 :            : 
     988                 :            : bool
     989                 :       2459 : gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
     990                 :            :                        locus *where ATTRIBUTE_UNUSED)
     991                 :            : {
     992                 :       2459 :   attr->ext_attr |= 1 << ext_attr;
     993                 :       2459 :   return true;
     994                 :            : }
     995                 :            : 
     996                 :            : 
     997                 :            : /* Called from decl.c (attr_decl1) to check attributes, when declared
     998                 :            :    separately.  */
     999                 :            : 
    1000                 :            : bool
    1001                 :       7084 : gfc_add_attribute (symbol_attribute *attr, locus *where)
    1002                 :            : {
    1003                 :       7084 :   if (check_used (attr, NULL, where))
    1004                 :          0 :     return false;
    1005                 :            : 
    1006                 :       7084 :   return gfc_check_conflict (attr, NULL, where);
    1007                 :            : }
    1008                 :            : 
    1009                 :            : 
    1010                 :            : bool
    1011                 :      20589 : gfc_add_allocatable (symbol_attribute *attr, locus *where)
    1012                 :            : {
    1013                 :            : 
    1014                 :      20589 :   if (check_used (attr, NULL, where))
    1015                 :          0 :     return false;
    1016                 :            : 
    1017                 :      20589 :   if (attr->allocatable && ! gfc_submodule_procedure(attr))
    1018                 :            :     {
    1019                 :          0 :       duplicate_attr ("ALLOCATABLE", where);
    1020                 :          0 :       return false;
    1021                 :            :     }
    1022                 :            : 
    1023                 :      20589 :   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    1024                 :      20589 :       && !gfc_find_state (COMP_INTERFACE))
    1025                 :            :     {
    1026                 :          1 :       gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
    1027                 :            :                  where);
    1028                 :          1 :       return false;
    1029                 :            :     }
    1030                 :            : 
    1031                 :      20588 :   attr->allocatable = 1;
    1032                 :      20588 :   return gfc_check_conflict (attr, NULL, where);
    1033                 :            : }
    1034                 :            : 
    1035                 :            : 
    1036                 :            : bool
    1037                 :         82 : gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
    1038                 :            : {
    1039                 :         82 :   if (check_used (attr, name, where))
    1040                 :            :     return false;
    1041                 :            : 
    1042                 :          0 :   if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
    1043                 :         82 :         "Duplicate AUTOMATIC attribute specified at %L", where))
    1044                 :            :     return false;
    1045                 :            : 
    1046                 :         82 :   attr->automatic = 1;
    1047                 :         82 :   return gfc_check_conflict (attr, name, where);
    1048                 :            : }
    1049                 :            : 
    1050                 :            : 
    1051                 :            : bool
    1052                 :       1204 : gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
    1053                 :            : {
    1054                 :            : 
    1055                 :       1204 :   if (check_used (attr, name, where))
    1056                 :            :     return false;
    1057                 :            : 
    1058                 :       1204 :   if (attr->codimension)
    1059                 :            :     {
    1060                 :          1 :       duplicate_attr ("CODIMENSION", where);
    1061                 :          1 :       return false;
    1062                 :            :     }
    1063                 :            : 
    1064                 :       1203 :   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    1065                 :       1203 :       && !gfc_find_state (COMP_INTERFACE))
    1066                 :            :     {
    1067                 :          0 :       gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
    1068                 :            :                  "at %L", name, where);
    1069                 :          0 :       return false;
    1070                 :            :     }
    1071                 :            : 
    1072                 :       1203 :   attr->codimension = 1;
    1073                 :       1203 :   return gfc_check_conflict (attr, name, where);
    1074                 :            : }
    1075                 :            : 
    1076                 :            : 
    1077                 :            : bool
    1078                 :      70093 : gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
    1079                 :            : {
    1080                 :            : 
    1081                 :      70093 :   if (check_used (attr, name, where))
    1082                 :            :     return false;
    1083                 :            : 
    1084                 :      70093 :   if (attr->dimension && ! gfc_submodule_procedure(attr))
    1085                 :            :     {
    1086                 :          0 :       duplicate_attr ("DIMENSION", where);
    1087                 :          0 :       return false;
    1088                 :            :     }
    1089                 :            : 
    1090                 :      70093 :   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
    1091                 :      70093 :       && !gfc_find_state (COMP_INTERFACE))
    1092                 :            :     {
    1093                 :          1 :       gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
    1094                 :            :                  "at %L", name, where);
    1095                 :          1 :       return false;
    1096                 :            :     }
    1097                 :            : 
    1098                 :      70092 :   attr->dimension = 1;
    1099                 :      70092 :   return gfc_check_conflict (attr, name, where);
    1100                 :            : }
    1101                 :            : 
    1102                 :            : 
    1103                 :            : bool
    1104                 :       2551 : gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
    1105                 :            : {
    1106                 :            : 
    1107                 :       2551 :   if (check_used (attr, name, where))
    1108                 :            :     return false;
    1109                 :            : 
    1110                 :       2551 :   attr->contiguous = 1;
    1111                 :       2551 :   return gfc_check_conflict (attr, name, where);
    1112                 :            : }
    1113                 :            : 
    1114                 :            : 
    1115                 :            : bool
    1116                 :      12503 : gfc_add_external (symbol_attribute *attr, locus *where)
    1117                 :            : {
    1118                 :            : 
    1119                 :      12503 :   if (check_used (attr, NULL, where))
    1120                 :          3 :     return false;
    1121                 :            : 
    1122                 :      12500 :   if (attr->external)
    1123                 :            :     {
    1124                 :          3 :       duplicate_attr ("EXTERNAL", where);
    1125                 :          3 :       return false;
    1126                 :            :     }
    1127                 :            : 
    1128                 :      12497 :   if (attr->pointer && attr->if_source != IFSRC_IFBODY)
    1129                 :            :     {
    1130                 :        676 :       attr->pointer = 0;
    1131                 :        676 :       attr->proc_pointer = 1;
    1132                 :            :     }
    1133                 :            : 
    1134                 :      12497 :   attr->external = 1;
    1135                 :            : 
    1136                 :      12497 :   return gfc_check_conflict (attr, NULL, where);
    1137                 :            : }
    1138                 :            : 
    1139                 :            : 
    1140                 :            : bool
    1141                 :       1683 : gfc_add_intrinsic (symbol_attribute *attr, locus *where)
    1142                 :            : {
    1143                 :            : 
    1144                 :       1683 :   if (check_used (attr, NULL, where))
    1145                 :          0 :     return false;
    1146                 :            : 
    1147                 :       1683 :   if (attr->intrinsic)
    1148                 :            :     {
    1149                 :          0 :       duplicate_attr ("INTRINSIC", where);
    1150                 :          0 :       return false;
    1151                 :            :     }
    1152                 :            : 
    1153                 :       1683 :   attr->intrinsic = 1;
    1154                 :            : 
    1155                 :       1683 :   return gfc_check_conflict (attr, NULL, where);
    1156                 :            : }
    1157                 :            : 
    1158                 :            : 
    1159                 :            : bool
    1160                 :       5984 : gfc_add_optional (symbol_attribute *attr, locus *where)
    1161                 :            : {
    1162                 :            : 
    1163                 :       5984 :   if (check_used (attr, NULL, where))
    1164                 :          0 :     return false;
    1165                 :            : 
    1166                 :       5984 :   if (attr->optional)
    1167                 :            :     {
    1168                 :          0 :       duplicate_attr ("OPTIONAL", where);
    1169                 :          0 :       return false;
    1170                 :            :     }
    1171                 :            : 
    1172                 :       5984 :   attr->optional = 1;
    1173                 :       5984 :   return gfc_check_conflict (attr, NULL, where);
    1174                 :            : }
    1175                 :            : 
    1176                 :            : bool
    1177                 :        117 : gfc_add_kind (symbol_attribute *attr, locus *where)
    1178                 :            : {
    1179                 :        117 :   if (attr->pdt_kind)
    1180                 :            :     {
    1181                 :          0 :       duplicate_attr ("KIND", where);
    1182                 :          0 :       return false;
    1183                 :            :     }
    1184                 :            : 
    1185                 :        117 :   attr->pdt_kind = 1;
    1186                 :        117 :   return gfc_check_conflict (attr, NULL, where);
    1187                 :            : }
    1188                 :            : 
    1189                 :            : bool
    1190                 :        142 : gfc_add_len (symbol_attribute *attr, locus *where)
    1191                 :            : {
    1192                 :        142 :   if (attr->pdt_len)
    1193                 :            :     {
    1194                 :          0 :       duplicate_attr ("LEN", where);
    1195                 :          0 :       return false;
    1196                 :            :     }
    1197                 :            : 
    1198                 :        142 :   attr->pdt_len = 1;
    1199                 :        142 :   return gfc_check_conflict (attr, NULL, where);
    1200                 :            : }
    1201                 :            : 
    1202                 :            : 
    1203                 :            : bool
    1204                 :      17468 : gfc_add_pointer (symbol_attribute *attr, locus *where)
    1205                 :            : {
    1206                 :            : 
    1207                 :      17468 :   if (check_used (attr, NULL, where))
    1208                 :          0 :     return false;
    1209                 :            : 
    1210                 :          2 :   if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
    1211                 :          1 :       && !gfc_find_state (COMP_INTERFACE))
    1212                 :      17468 :       && ! gfc_submodule_procedure(attr))
    1213                 :            :     {
    1214                 :          0 :       duplicate_attr ("POINTER", where);
    1215                 :          0 :       return false;
    1216                 :            :     }
    1217                 :            : 
    1218                 :      17460 :   if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
    1219                 :      34907 :       || (attr->if_source == IFSRC_IFBODY
    1220                 :        163 :       && !gfc_find_state (COMP_INTERFACE)))
    1221                 :         35 :     attr->proc_pointer = 1;
    1222                 :            :   else
    1223                 :      17433 :     attr->pointer = 1;
    1224                 :            : 
    1225                 :      17468 :   return gfc_check_conflict (attr, NULL, where);
    1226                 :            : }
    1227                 :            : 
    1228                 :            : 
    1229                 :            : bool
    1230                 :        640 : gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
    1231                 :            : {
    1232                 :            : 
    1233                 :        640 :   if (check_used (attr, NULL, where))
    1234                 :          0 :     return false;
    1235                 :            : 
    1236                 :        640 :   attr->cray_pointer = 1;
    1237                 :        640 :   return gfc_check_conflict (attr, NULL, where);
    1238                 :            : }
    1239                 :            : 
    1240                 :            : 
    1241                 :            : bool
    1242                 :        624 : gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
    1243                 :            : {
    1244                 :            : 
    1245                 :        624 :   if (check_used (attr, NULL, where))
    1246                 :          0 :     return false;
    1247                 :            : 
    1248                 :        624 :   if (attr->cray_pointee)
    1249                 :            :     {
    1250                 :          1 :       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
    1251                 :            :                  " statements", where);
    1252                 :          1 :       return false;
    1253                 :            :     }
    1254                 :            : 
    1255                 :        623 :   attr->cray_pointee = 1;
    1256                 :        623 :   return gfc_check_conflict (attr, NULL, where);
    1257                 :            : }
    1258                 :            : 
    1259                 :            : 
    1260                 :            : bool
    1261                 :         96 : gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
    1262                 :            : {
    1263                 :         96 :   if (check_used (attr, name, where))
    1264                 :            :     return false;
    1265                 :            : 
    1266                 :         96 :   if (attr->is_protected)
    1267                 :            :     {
    1268                 :          0 :         if (!gfc_notify_std (GFC_STD_LEGACY,
    1269                 :            :                              "Duplicate PROTECTED attribute specified at %L",
    1270                 :            :                              where))
    1271                 :            :           return false;
    1272                 :            :     }
    1273                 :            : 
    1274                 :         96 :   attr->is_protected = 1;
    1275                 :         96 :   return gfc_check_conflict (attr, name, where);
    1276                 :            : }
    1277                 :            : 
    1278                 :            : 
    1279                 :            : bool
    1280                 :       4279 : gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
    1281                 :            : {
    1282                 :            : 
    1283                 :       4279 :   if (check_used (attr, name, where))
    1284                 :            :     return false;
    1285                 :            : 
    1286                 :       4279 :   attr->result = 1;
    1287                 :       4279 :   return gfc_check_conflict (attr, name, where);
    1288                 :            : }
    1289                 :            : 
    1290                 :            : 
    1291                 :            : bool
    1292                 :       6997 : gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
    1293                 :            :               locus *where)
    1294                 :            : {
    1295                 :            : 
    1296                 :       6997 :   if (check_used (attr, name, where))
    1297                 :            :     return false;
    1298                 :            : 
    1299                 :       6997 :   if (s == SAVE_EXPLICIT && gfc_pure (NULL))
    1300                 :            :     {
    1301                 :          2 :       gfc_error
    1302                 :          2 :         ("SAVE attribute at %L cannot be specified in a PURE procedure",
    1303                 :            :          where);
    1304                 :          2 :       return false;
    1305                 :            :     }
    1306                 :            : 
    1307                 :       6995 :   if (s == SAVE_EXPLICIT)
    1308                 :       3239 :     gfc_unset_implicit_pure (NULL);
    1309                 :            : 
    1310                 :       6995 :   if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
    1311                 :         56 :       && (flag_automatic || pedantic))
    1312                 :            :     {
    1313                 :         20 :         if (!gfc_notify_std (GFC_STD_LEGACY,
    1314                 :            :                              "Duplicate SAVE attribute specified at %L",
    1315                 :            :                              where))
    1316                 :            :           return false;
    1317                 :            :     }
    1318                 :            : 
    1319                 :       6993 :   attr->save = s;
    1320                 :       6993 :   return gfc_check_conflict (attr, name, where);
    1321                 :            : }
    1322                 :            : 
    1323                 :            : 
    1324                 :            : bool
    1325                 :       5191 : gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
    1326                 :            : {
    1327                 :            : 
    1328                 :       5191 :   if (check_used (attr, name, where))
    1329                 :            :     return false;
    1330                 :            : 
    1331                 :       5191 :   if (attr->value)
    1332                 :            :     {
    1333                 :          0 :         if (!gfc_notify_std (GFC_STD_LEGACY,
    1334                 :            :                              "Duplicate VALUE attribute specified at %L",
    1335                 :            :                              where))
    1336                 :            :           return false;
    1337                 :            :     }
    1338                 :            : 
    1339                 :       5191 :   attr->value = 1;
    1340                 :       5191 :   return gfc_check_conflict (attr, name, where);
    1341                 :            : }
    1342                 :            : 
    1343                 :            : 
    1344                 :            : bool
    1345                 :        958 : gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
    1346                 :            : {
    1347                 :            :   /* No check_used needed as 11.2.1 of the F2003 standard allows
    1348                 :            :      that the local identifier made accessible by a use statement can be
    1349                 :            :      given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
    1350                 :            : 
    1351                 :        958 :   if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
    1352                 :          1 :     if (!gfc_notify_std (GFC_STD_LEGACY,
    1353                 :            :                          "Duplicate VOLATILE attribute specified at %L",
    1354                 :            :                          where))
    1355                 :            :       return false;
    1356                 :            : 
    1357                 :            :   /* F2008:  C1282 A designator of a variable with the VOLATILE attribute
    1358                 :            :      shall not appear in a pure subprogram.
    1359                 :            : 
    1360                 :            :      F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
    1361                 :            :      construct within a pure subprogram, shall not have the SAVE or
    1362                 :            :      VOLATILE attribute.  */
    1363                 :        958 :   if (gfc_pure (NULL))
    1364                 :            :     {
    1365                 :          2 :       gfc_error ("VOLATILE attribute at %L cannot be specified in a "
    1366                 :            :                  "PURE procedure", where);
    1367                 :          2 :       return false;
    1368                 :            :     }
    1369                 :            : 
    1370                 :            : 
    1371                 :        956 :   attr->volatile_ = 1;
    1372                 :        956 :   attr->volatile_ns = gfc_current_ns;
    1373                 :        956 :   return gfc_check_conflict (attr, name, where);
    1374                 :            : }
    1375                 :            : 
    1376                 :            : 
    1377                 :            : bool
    1378                 :         53 : gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
    1379                 :            : {
    1380                 :            :   /* No check_used needed as 11.2.1 of the F2003 standard allows
    1381                 :            :      that the local identifier made accessible by a use statement can be
    1382                 :            :      given a ASYNCHRONOUS attribute.  */
    1383                 :            : 
    1384                 :         53 :   if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
    1385                 :          0 :     if (!gfc_notify_std (GFC_STD_LEGACY,
    1386                 :            :                          "Duplicate ASYNCHRONOUS attribute specified at %L",
    1387                 :            :                          where))
    1388                 :            :       return false;
    1389                 :            : 
    1390                 :         53 :   attr->asynchronous = 1;
    1391                 :         53 :   attr->asynchronous_ns = gfc_current_ns;
    1392                 :         53 :   return gfc_check_conflict (attr, name, where);
    1393                 :            : }
    1394                 :            : 
    1395                 :            : 
    1396                 :            : bool
    1397                 :        273 : gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
    1398                 :            : {
    1399                 :            : 
    1400                 :        273 :   if (check_used (attr, name, where))
    1401                 :            :     return false;
    1402                 :            : 
    1403                 :        273 :   if (attr->threadprivate)
    1404                 :            :     {
    1405                 :          0 :       duplicate_attr ("THREADPRIVATE", where);
    1406                 :          0 :       return false;
    1407                 :            :     }
    1408                 :            : 
    1409                 :        273 :   attr->threadprivate = 1;
    1410                 :        273 :   return gfc_check_conflict (attr, name, where);
    1411                 :            : }
    1412                 :            : 
    1413                 :            : 
    1414                 :            : bool
    1415                 :        458 : gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
    1416                 :            :                             locus *where)
    1417                 :            : {
    1418                 :            : 
    1419                 :        458 :   if (check_used (attr, name, where))
    1420                 :            :     return false;
    1421                 :            : 
    1422                 :        454 :   if (attr->omp_declare_target)
    1423                 :            :     return true;
    1424                 :            : 
    1425                 :        419 :   attr->omp_declare_target = 1;
    1426                 :        419 :   return gfc_check_conflict (attr, name, where);
    1427                 :            : }
    1428                 :            : 
    1429                 :            : 
    1430                 :            : bool
    1431                 :         24 : gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
    1432                 :            :                                  locus *where)
    1433                 :            : {
    1434                 :            : 
    1435                 :         24 :   if (check_used (attr, name, where))
    1436                 :            :     return false;
    1437                 :            : 
    1438                 :         24 :   if (attr->omp_declare_target_link)
    1439                 :            :     return true;
    1440                 :            : 
    1441                 :         15 :   attr->omp_declare_target_link = 1;
    1442                 :         15 :   return gfc_check_conflict (attr, name, where);
    1443                 :            : }
    1444                 :            : 
    1445                 :            : 
    1446                 :            : bool
    1447                 :          0 : gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
    1448                 :            :                              locus *where)
    1449                 :            : {
    1450                 :          0 :   if (check_used (attr, name, where))
    1451                 :            :     return false;
    1452                 :            : 
    1453                 :          0 :   if (attr->oacc_declare_create)
    1454                 :            :     return true;
    1455                 :            : 
    1456                 :          0 :   attr->oacc_declare_create = 1;
    1457                 :          0 :   return gfc_check_conflict (attr, name, where);
    1458                 :            : }
    1459                 :            : 
    1460                 :            : 
    1461                 :            : bool
    1462                 :          0 : gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
    1463                 :            :                              locus *where)
    1464                 :            : {
    1465                 :          0 :   if (check_used (attr, name, where))
    1466                 :            :     return false;
    1467                 :            : 
    1468                 :          0 :   if (attr->oacc_declare_copyin)
    1469                 :            :     return true;
    1470                 :            : 
    1471                 :          0 :   attr->oacc_declare_copyin = 1;
    1472                 :          0 :   return gfc_check_conflict (attr, name, where);
    1473                 :            : }
    1474                 :            : 
    1475                 :            : 
    1476                 :            : bool
    1477                 :          0 : gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
    1478                 :            :                                 locus *where)
    1479                 :            : {
    1480                 :          0 :   if (check_used (attr, name, where))
    1481                 :            :     return false;
    1482                 :            : 
    1483                 :          0 :   if (attr->oacc_declare_deviceptr)
    1484                 :            :     return true;
    1485                 :            : 
    1486                 :          0 :   attr->oacc_declare_deviceptr = 1;
    1487                 :          0 :   return gfc_check_conflict (attr, name, where);
    1488                 :            : }
    1489                 :            : 
    1490                 :            : 
    1491                 :            : bool
    1492                 :          0 : gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
    1493                 :            :                                       locus *where)
    1494                 :            : {
    1495                 :          0 :   if (check_used (attr, name, where))
    1496                 :            :     return false;
    1497                 :            : 
    1498                 :          0 :   if (attr->oacc_declare_device_resident)
    1499                 :            :     return true;
    1500                 :            : 
    1501                 :          0 :   attr->oacc_declare_device_resident = 1;
    1502                 :          0 :   return gfc_check_conflict (attr, name, where);
    1503                 :            : }
    1504                 :            : 
    1505                 :            : 
    1506                 :            : bool
    1507                 :       8257 : gfc_add_target (symbol_attribute *attr, locus *where)
    1508                 :            : {
    1509                 :            : 
    1510                 :       8257 :   if (check_used (attr, NULL, where))
    1511                 :          0 :     return false;
    1512                 :            : 
    1513                 :       8257 :   if (attr->target)
    1514                 :            :     {
    1515                 :          0 :       duplicate_attr ("TARGET", where);
    1516                 :          0 :       return false;
    1517                 :            :     }
    1518                 :            : 
    1519                 :       8257 :   attr->target = 1;
    1520                 :       8257 :   return gfc_check_conflict (attr, NULL, where);
    1521                 :            : }
    1522                 :            : 
    1523                 :            : 
    1524                 :            : bool
    1525                 :      63418 : gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
    1526                 :            : {
    1527                 :            : 
    1528                 :      63418 :   if (check_used (attr, name, where))
    1529                 :            :     return false;
    1530                 :            : 
    1531                 :            :   /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
    1532                 :      63418 :   attr->dummy = 1;
    1533                 :      63418 :   return gfc_check_conflict (attr, name, where);
    1534                 :            : }
    1535                 :            : 
    1536                 :            : 
    1537                 :            : bool
    1538                 :      11466 : gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
    1539                 :            : {
    1540                 :            : 
    1541                 :      11466 :   if (check_used (attr, name, where))
    1542                 :            :     return false;
    1543                 :            : 
    1544                 :            :   /* Duplicate attribute already checked for.  */
    1545                 :      11466 :   attr->in_common = 1;
    1546                 :      11466 :   return gfc_check_conflict (attr, name, where);
    1547                 :            : }
    1548                 :            : 
    1549                 :            : 
    1550                 :            : bool
    1551                 :       2949 : gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
    1552                 :            : {
    1553                 :            : 
    1554                 :            :   /* Duplicate attribute already checked for.  */
    1555                 :       2949 :   attr->in_equivalence = 1;
    1556                 :       2949 :   if (!gfc_check_conflict (attr, name, where))
    1557                 :            :     return false;
    1558                 :            : 
    1559                 :       2945 :   if (attr->flavor == FL_VARIABLE)
    1560                 :            :     return true;
    1561                 :            : 
    1562                 :        109 :   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
    1563                 :            : }
    1564                 :            : 
    1565                 :            : 
    1566                 :            : bool
    1567                 :       2819 : gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
    1568                 :            : {
    1569                 :            : 
    1570                 :       2819 :   if (check_used (attr, name, where))
    1571                 :            :     return false;
    1572                 :            : 
    1573                 :       2818 :   attr->data = 1;
    1574                 :       2818 :   return gfc_check_conflict (attr, name, where);
    1575                 :            : }
    1576                 :            : 
    1577                 :            : 
    1578                 :            : bool
    1579                 :       1901 : gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
    1580                 :            : {
    1581                 :            : 
    1582                 :       1901 :   attr->in_namelist = 1;
    1583                 :       1901 :   return gfc_check_conflict (attr, name, where);
    1584                 :            : }
    1585                 :            : 
    1586                 :            : 
    1587                 :            : bool
    1588                 :        946 : gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
    1589                 :            : {
    1590                 :            : 
    1591                 :        946 :   if (check_used (attr, name, where))
    1592                 :            :     return false;
    1593                 :            : 
    1594                 :        946 :   attr->sequence = 1;
    1595                 :        946 :   return gfc_check_conflict (attr, name, where);
    1596                 :            : }
    1597                 :            : 
    1598                 :            : 
    1599                 :            : bool
    1600                 :       5752 : gfc_add_elemental (symbol_attribute *attr, locus *where)
    1601                 :            : {
    1602                 :            : 
    1603                 :       5752 :   if (check_used (attr, NULL, where))
    1604                 :          0 :     return false;
    1605                 :            : 
    1606                 :       5752 :   if (attr->elemental)
    1607                 :            :     {
    1608                 :          2 :       duplicate_attr ("ELEMENTAL", where);
    1609                 :          2 :       return false;
    1610                 :            :     }
    1611                 :            : 
    1612                 :       5750 :   attr->elemental = 1;
    1613                 :       5750 :   return gfc_check_conflict (attr, NULL, where);
    1614                 :            : }
    1615                 :            : 
    1616                 :            : 
    1617                 :            : bool
    1618                 :       8178 : gfc_add_pure (symbol_attribute *attr, locus *where)
    1619                 :            : {
    1620                 :            : 
    1621                 :       8178 :   if (check_used (attr, NULL, where))
    1622                 :          0 :     return false;
    1623                 :            : 
    1624                 :       8178 :   if (attr->pure)
    1625                 :            :     {
    1626                 :          2 :       duplicate_attr ("PURE", where);
    1627                 :          2 :       return false;
    1628                 :            :     }
    1629                 :            : 
    1630                 :       8176 :   attr->pure = 1;
    1631                 :       8176 :   return gfc_check_conflict (attr, NULL, where);
    1632                 :            : }
    1633                 :            : 
    1634                 :            : 
    1635                 :            : bool
    1636                 :        665 : gfc_add_recursive (symbol_attribute *attr, locus *where)
    1637                 :            : {
    1638                 :            : 
    1639                 :        665 :   if (check_used (attr, NULL, where))
    1640                 :          0 :     return false;
    1641                 :            : 
    1642                 :        665 :   if (attr->recursive)
    1643                 :            :     {
    1644                 :          2 :       duplicate_attr ("RECURSIVE", where);
    1645                 :          2 :       return false;
    1646                 :            :     }
    1647                 :            : 
    1648                 :        663 :   attr->recursive = 1;
    1649                 :        663 :   return gfc_check_conflict (attr, NULL, where);
    1650                 :            : }
    1651                 :            : 
    1652                 :            : 
    1653                 :            : bool
    1654                 :        696 : gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
    1655                 :            : {
    1656                 :            : 
    1657                 :        696 :   if (check_used (attr, name, where))
    1658                 :            :     return false;
    1659                 :            : 
    1660                 :        696 :   if (attr->entry)
    1661                 :            :     {
    1662                 :          0 :       duplicate_attr ("ENTRY", where);
    1663                 :          0 :       return false;
    1664                 :            :     }
    1665                 :            : 
    1666                 :        696 :   attr->entry = 1;
    1667                 :        696 :   return gfc_check_conflict (attr, name, where);
    1668                 :            : }
    1669                 :            : 
    1670                 :            : 
    1671                 :            : bool
    1672                 :     666165 : gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
    1673                 :            : {
    1674                 :            : 
    1675                 :     666165 :   if (attr->flavor != FL_PROCEDURE
    1676                 :     666165 :       && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
    1677                 :            :     return false;
    1678                 :            : 
    1679                 :     666165 :   attr->function = 1;
    1680                 :     666165 :   return gfc_check_conflict (attr, name, where);
    1681                 :            : }
    1682                 :            : 
    1683                 :            : 
    1684                 :            : bool
    1685                 :      76744 : gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
    1686                 :            : {
    1687                 :            : 
    1688                 :      76744 :   if (attr->flavor != FL_PROCEDURE
    1689                 :      76744 :       && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
    1690                 :            :     return false;
    1691                 :            : 
    1692                 :      76741 :   attr->subroutine = 1;
    1693                 :            : 
    1694                 :            :   /* If we are looking at a BLOCK DATA statement and we encounter a
    1695                 :            :      name with a leading underscore (which must be
    1696                 :            :      compiler-generated), do not check. See PR 84394.  */
    1697                 :            : 
    1698                 :      76741 :   if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
    1699                 :      50338 :     return gfc_check_conflict (attr, name, where);
    1700                 :            :   else
    1701                 :            :     return true;
    1702                 :            : }
    1703                 :            : 
    1704                 :            : 
    1705                 :            : bool
    1706                 :      15393 : gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
    1707                 :            : {
    1708                 :            : 
    1709                 :      15393 :   if (attr->flavor != FL_PROCEDURE
    1710                 :      15393 :       && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
    1711                 :            :     return false;
    1712                 :            : 
    1713                 :      15391 :   attr->generic = 1;
    1714                 :      15391 :   return gfc_check_conflict (attr, name, where);
    1715                 :            : }
    1716                 :            : 
    1717                 :            : 
    1718                 :            : bool
    1719                 :       1389 : gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
    1720                 :            : {
    1721                 :            : 
    1722                 :       1389 :   if (check_used (attr, NULL, where))
    1723                 :          0 :     return false;
    1724                 :            : 
    1725                 :       1389 :   if (attr->flavor != FL_PROCEDURE
    1726                 :       1389 :       && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
    1727                 :            :     return false;
    1728                 :            : 
    1729                 :       1389 :   if (attr->procedure)
    1730                 :            :     {
    1731                 :          0 :       duplicate_attr ("PROCEDURE", where);
    1732                 :          0 :       return false;
    1733                 :            :     }
    1734                 :            : 
    1735                 :       1389 :   attr->procedure = 1;
    1736                 :            : 
    1737                 :       1389 :   return gfc_check_conflict (attr, NULL, where);
    1738                 :            : }
    1739                 :            : 
    1740                 :            : 
    1741                 :            : bool
    1742                 :        626 : gfc_add_abstract (symbol_attribute* attr, locus* where)
    1743                 :            : {
    1744                 :        626 :   if (attr->abstract)
    1745                 :            :     {
    1746                 :          1 :       duplicate_attr ("ABSTRACT", where);
    1747                 :          1 :       return false;
    1748                 :            :     }
    1749                 :            : 
    1750                 :        625 :   attr->abstract = 1;
    1751                 :            : 
    1752                 :        625 :   return gfc_check_conflict (attr, NULL, where);
    1753                 :            : }
    1754                 :            : 
    1755                 :            : 
    1756                 :            : /* Flavors are special because some flavors are not what Fortran
    1757                 :            :    considers attributes and can be reaffirmed multiple times.  */
    1758                 :            : 
    1759                 :            : bool
    1760                 :    2518340 : gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
    1761                 :            :                 locus *where)
    1762                 :            : {
    1763                 :            : 
    1764                 :    2518340 :   if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
    1765                 :    2472450 :        || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)
    1766                 :    4990790 :        || f == FL_NAMELIST) && check_used (attr, name, where))
    1767                 :            :     return false;
    1768                 :            : 
    1769                 :    2518340 :   if (attr->flavor == f && f == FL_VARIABLE)
    1770                 :            :     return true;
    1771                 :            : 
    1772                 :            :   /* Copying a procedure dummy argument for a module procedure in a
    1773                 :            :      submodule results in the flavor being copied and would result in
    1774                 :            :      an error without this.  */
    1775                 :    2518340 :   if (gfc_new_block && gfc_new_block->abr_modproc_decl
    1776                 :        169 :       && attr->flavor == f && f == FL_PROCEDURE)
    1777                 :            :     return true;
    1778                 :            : 
    1779                 :    2518330 :   if (attr->flavor != FL_UNKNOWN)
    1780                 :            :     {
    1781                 :        462 :       if (where == NULL)
    1782                 :        350 :         where = &gfc_current_locus;
    1783                 :            : 
    1784                 :        462 :       if (name)
    1785                 :        350 :         gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
    1786                 :        175 :                    gfc_code2string (flavors, attr->flavor), name,
    1787                 :            :                    gfc_code2string (flavors, f), where);
    1788                 :            :       else
    1789                 :        574 :         gfc_error ("%s attribute conflicts with %s attribute at %L",
    1790                 :        287 :                    gfc_code2string (flavors, attr->flavor),
    1791                 :            :                    gfc_code2string (flavors, f), where);
    1792                 :            : 
    1793                 :        462 :       return false;
    1794                 :            :     }
    1795                 :            : 
    1796                 :    2517870 :   attr->flavor = f;
    1797                 :            : 
    1798                 :    2517870 :   return gfc_check_conflict (attr, name, where);
    1799                 :            : }
    1800                 :            : 
    1801                 :            : 
    1802                 :            : bool
    1803                 :     968428 : gfc_add_procedure (symbol_attribute *attr, procedure_type t,
    1804                 :            :                    const char *name, locus *where)
    1805                 :            : {
    1806                 :            : 
    1807                 :     968428 :   if (check_used (attr, name, where))
    1808                 :            :     return false;
    1809                 :            : 
    1810                 :     968400 :   if (attr->flavor != FL_PROCEDURE
    1811                 :     968400 :       && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
    1812                 :            :     return false;
    1813                 :            : 
    1814                 :     968350 :   if (where == NULL)
    1815                 :     957336 :     where = &gfc_current_locus;
    1816                 :            : 
    1817                 :     968350 :   if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
    1818                 :        142 :       && attr->access == ACCESS_UNKNOWN)
    1819                 :            :     {
    1820                 :          0 :       if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
    1821                 :        116 :           && !gfc_notification_std (GFC_STD_F2008))
    1822                 :          0 :         gfc_error ("%s procedure at %L is already declared as %s "
    1823                 :            :                    "procedure. \nF2008: A pointer function assignment "
    1824                 :            :                    "is ambiguous if it is the first executable statement "
    1825                 :            :                    "after the specification block. Please add any other "
    1826                 :            :                    "kind of executable statement before it. FIXME",
    1827                 :            :                  gfc_code2string (procedures, t), where,
    1828                 :          0 :                  gfc_code2string (procedures, attr->proc));
    1829                 :            :       else
    1830                 :        116 :         gfc_error ("%s procedure at %L is already declared as %s "
    1831                 :            :                    "procedure", gfc_code2string (procedures, t), where,
    1832                 :        116 :                    gfc_code2string (procedures, attr->proc));
    1833                 :            : 
    1834                 :        116 :       return false;
    1835                 :            :     }
    1836                 :            : 
    1837                 :     968234 :   attr->proc = t;
    1838                 :            : 
    1839                 :            :   /* Statement functions are always scalar and functions.  */
    1840                 :     968234 :   if (t == PROC_ST_FUNCTION
    1841                 :     968234 :       && ((!attr->function && !gfc_add_function (attr, name, where))
    1842                 :     282254 :           || attr->dimension))
    1843                 :         18 :     return false;
    1844                 :            : 
    1845                 :     968216 :   return gfc_check_conflict (attr, name, where);
    1846                 :            : }
    1847                 :            : 
    1848                 :            : 
    1849                 :            : bool
    1850                 :      37590 : gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
    1851                 :            : {
    1852                 :            : 
    1853                 :      37590 :   if (check_used (attr, NULL, where))
    1854                 :          0 :     return false;
    1855                 :            : 
    1856                 :      37590 :   if (attr->intent == INTENT_UNKNOWN)
    1857                 :            :     {
    1858                 :      37590 :       attr->intent = intent;
    1859                 :      37590 :       return gfc_check_conflict (attr, NULL, where);
    1860                 :            :     }
    1861                 :            : 
    1862                 :          0 :   if (where == NULL)
    1863                 :          0 :     where = &gfc_current_locus;
    1864                 :            : 
    1865                 :          0 :   gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
    1866                 :          0 :              gfc_intent_string (attr->intent),
    1867                 :            :              gfc_intent_string (intent), where);
    1868                 :            : 
    1869                 :          0 :   return false;
    1870                 :            : }
    1871                 :            : 
    1872                 :            : 
    1873                 :            : /* No checks for use-association in public and private statements.  */
    1874                 :            : 
    1875                 :            : bool
    1876                 :       4004 : gfc_add_access (symbol_attribute *attr, gfc_access access,
    1877                 :            :                 const char *name, locus *where)
    1878                 :            : {
    1879                 :            : 
    1880                 :       4004 :   if (attr->access == ACCESS_UNKNOWN
    1881                 :          5 :         || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
    1882                 :            :     {
    1883                 :       4000 :       attr->access = access;
    1884                 :       4000 :       return gfc_check_conflict (attr, name, where);
    1885                 :            :     }
    1886                 :            : 
    1887                 :          4 :   if (where == NULL)
    1888                 :          3 :     where = &gfc_current_locus;
    1889                 :          4 :   gfc_error ("ACCESS specification at %L was already specified", where);
    1890                 :            : 
    1891                 :          4 :   return false;
    1892                 :            : }
    1893                 :            : 
    1894                 :            : 
    1895                 :            : /* Set the is_bind_c field for the given symbol_attribute.  */
    1896                 :            : 
    1897                 :            : bool
    1898                 :       1908 : gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
    1899                 :            :                    int is_proc_lang_bind_spec)
    1900                 :            : {
    1901                 :            : 
    1902                 :       1908 :   if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
    1903                 :          5 :     gfc_error_now ("BIND(C) attribute at %L can only be used for "
    1904                 :            :                    "variables or common blocks", where);
    1905                 :       1903 :   else if (attr->is_bind_c)
    1906                 :          1 :     gfc_error_now ("Duplicate BIND attribute specified at %L", where);
    1907                 :            :   else
    1908                 :       1902 :     attr->is_bind_c = 1;
    1909                 :            : 
    1910                 :       1908 :   if (where == NULL)
    1911                 :         52 :     where = &gfc_current_locus;
    1912                 :            : 
    1913                 :       1908 :   if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
    1914                 :            :     return false;
    1915                 :            : 
    1916                 :       1908 :   return gfc_check_conflict (attr, name, where);
    1917                 :            : }
    1918                 :            : 
    1919                 :            : 
    1920                 :            : /* Set the extension field for the given symbol_attribute.  */
    1921                 :            : 
    1922                 :            : bool
    1923                 :       1151 : gfc_add_extension (symbol_attribute *attr, locus *where)
    1924                 :            : {
    1925                 :       1151 :   if (where == NULL)
    1926                 :          0 :     where = &gfc_current_locus;
    1927                 :            : 
    1928                 :       1151 :   if (attr->extension)
    1929                 :          0 :     gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
    1930                 :            :   else
    1931                 :       1151 :     attr->extension = 1;
    1932                 :            : 
    1933                 :       1151 :   if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
    1934                 :          0 :     return false;
    1935                 :            : 
    1936                 :            :   return true;
    1937                 :            : }
    1938                 :            : 
    1939                 :            : 
    1940                 :            : bool
    1941                 :      92277 : gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
    1942                 :            :                             gfc_formal_arglist * formal, locus *where)
    1943                 :            : {
    1944                 :      92277 :   if (check_used (&sym->attr, sym->name, where))
    1945                 :            :     return false;
    1946                 :            : 
    1947                 :            :   /* Skip the following checks in the case of a module_procedures in a
    1948                 :            :      submodule since they will manifestly fail.  */
    1949                 :      92277 :   if (sym->attr.module_procedure == 1
    1950                 :        892 :       && source == IFSRC_DECL)
    1951                 :        595 :     goto finish;
    1952                 :            : 
    1953                 :      91682 :   if (where == NULL)
    1954                 :      91682 :     where = &gfc_current_locus;
    1955                 :            : 
    1956                 :      91682 :   if (sym->attr.if_source != IFSRC_UNKNOWN
    1957                 :      91682 :       && sym->attr.if_source != IFSRC_DECL)
    1958                 :            :     {
    1959                 :          1 :       gfc_error ("Symbol %qs at %L already has an explicit interface",
    1960                 :            :                  sym->name, where);
    1961                 :          1 :       return false;
    1962                 :            :     }
    1963                 :            : 
    1964                 :      91681 :   if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
    1965                 :            :     {
    1966                 :          2 :       gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
    1967                 :            :                  "body", sym->name, where);
    1968                 :          2 :       return false;
    1969                 :            :     }
    1970                 :            : 
    1971                 :      91679 : finish:
    1972                 :      92274 :   sym->formal = formal;
    1973                 :      92274 :   sym->attr.if_source = source;
    1974                 :            : 
    1975                 :      92274 :   return true;
    1976                 :            : }
    1977                 :            : 
    1978                 :            : 
    1979                 :            : /* Add a type to a symbol.  */
    1980                 :            : 
    1981                 :            : bool
    1982                 :     180532 : gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
    1983                 :            : {
    1984                 :     180532 :   sym_flavor flavor;
    1985                 :     180532 :   bt type;
    1986                 :            : 
    1987                 :     180532 :   if (where == NULL)
    1988                 :       2777 :     where = &gfc_current_locus;
    1989                 :            : 
    1990                 :     180532 :   if (sym->result)
    1991                 :       6178 :     type = sym->result->ts.type;
    1992                 :            :   else
    1993                 :     174354 :     type = sym->ts.type;
    1994                 :            : 
    1995                 :     180532 :   if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
    1996                 :       3016 :     type = sym->ns->proc_name->ts.type;
    1997                 :            : 
    1998                 :     180532 :   if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
    1999                 :         76 :       && !(gfc_state_stack->previous && gfc_state_stack->previous->previous
    2000                 :         59 :            && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
    2001                 :         43 :       && !sym->attr.module_procedure)
    2002                 :            :     {
    2003                 :         25 :       if (sym->attr.use_assoc)
    2004                 :          2 :         gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
    2005                 :            :                    "use-associated at %L", sym->name, where, sym->module,
    2006                 :            :                    &sym->declared_at);
    2007                 :            :       else
    2008                 :         23 :         gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
    2009                 :            :                  where, gfc_basic_typename (type));
    2010                 :         25 :       return false;
    2011                 :            :     }
    2012                 :            : 
    2013                 :     180507 :   if (sym->attr.procedure && sym->ts.interface)
    2014                 :            :     {
    2015                 :          1 :       gfc_error ("Procedure %qs at %L may not have basic type of %s",
    2016                 :            :                  sym->name, where, gfc_basic_typename (ts->type));
    2017                 :          1 :       return false;
    2018                 :            :     }
    2019                 :            : 
    2020                 :     180506 :   flavor = sym->attr.flavor;
    2021                 :            : 
    2022                 :     180506 :   if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
    2023                 :     180506 :       || flavor == FL_LABEL
    2024                 :     180505 :       || (flavor == FL_PROCEDURE && sym->attr.subroutine)
    2025                 :     180505 :       || flavor == FL_DERIVED || flavor == FL_NAMELIST)
    2026                 :            :     {
    2027                 :          1 :       gfc_error ("Symbol %qs at %L cannot have a type", sym->name, where);
    2028                 :          1 :       return false;
    2029                 :            :     }
    2030                 :            : 
    2031                 :     180505 :   sym->ts = *ts;
    2032                 :     180505 :   return true;
    2033                 :            : }
    2034                 :            : 
    2035                 :            : 
    2036                 :            : /* Clears all attributes.  */
    2037                 :            : 
    2038                 :            : void
    2039                 :    4465740 : gfc_clear_attr (symbol_attribute *attr)
    2040                 :            : {
    2041                 :    4465740 :   memset (attr, 0, sizeof (symbol_attribute));
    2042                 :    4465740 : }
    2043                 :            : 
    2044                 :            : 
    2045                 :            : /* Check for missing attributes in the new symbol.  Currently does
    2046                 :            :    nothing, but it's not clear that it is unnecessary yet.  */
    2047                 :            : 
    2048                 :            : bool
    2049                 :     256935 : gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
    2050                 :            :                   locus *where ATTRIBUTE_UNUSED)
    2051                 :            : {
    2052                 :            : 
    2053                 :     256935 :   return true;
    2054                 :            : }
    2055                 :            : 
    2056                 :            : 
    2057                 :            : /* Copy an attribute to a symbol attribute, bit by bit.  Some
    2058                 :            :    attributes have a lot of side-effects but cannot be present given
    2059                 :            :    where we are called from, so we ignore some bits.  */
    2060                 :            : 
    2061                 :            : bool
    2062                 :     181125 : gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
    2063                 :            : {
    2064                 :     181125 :   int is_proc_lang_bind_spec;
    2065                 :            : 
    2066                 :            :   /* In line with the other attributes, we only add bits but do not remove
    2067                 :            :      them; cf. also PR 41034.  */
    2068                 :     181125 :   dest->ext_attr |= src->ext_attr;
    2069                 :            : 
    2070                 :     181125 :   if (src->allocatable && !gfc_add_allocatable (dest, where))
    2071                 :          2 :     goto fail;
    2072                 :            : 
    2073                 :     181123 :   if (src->automatic && !gfc_add_automatic (dest, NULL, where))
    2074                 :          2 :     goto fail;
    2075                 :     181121 :   if (src->dimension && !gfc_add_dimension (dest, NULL, where))
    2076                 :          0 :     goto fail;
    2077                 :     181121 :   if (src->codimension && !gfc_add_codimension (dest, NULL, where))
    2078                 :          0 :     goto fail;
    2079                 :     181121 :   if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
    2080                 :          0 :     goto fail;
    2081                 :     181121 :   if (src->optional && !gfc_add_optional (dest, where))
    2082                 :          0 :     goto fail;
    2083                 :     181121 :   if (src->pointer && !gfc_add_pointer (dest, where))
    2084                 :          7 :     goto fail;
    2085                 :     181114 :   if (src->is_protected && !gfc_add_protected (dest, NULL, where))
    2086                 :          0 :     goto fail;
    2087                 :     181114 :   if (src->save && !gfc_add_save (dest, src->save, NULL, where))
    2088                 :          3 :     goto fail;
    2089                 :     181111 :   if (src->value && !gfc_add_value (dest, NULL, where))
    2090                 :          1 :     goto fail;
    2091                 :     181110 :   if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
    2092                 :          0 :     goto fail;
    2093                 :     181110 :   if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
    2094                 :          0 :     goto fail;
    2095                 :     181110 :   if (src->threadprivate
    2096                 :     181110 :       && !gfc_add_threadprivate (dest, NULL, where))
    2097                 :          0 :     goto fail;
    2098                 :     181110 :   if (src->omp_declare_target
    2099                 :     181110 :       && !gfc_add_omp_declare_target (dest, NULL, where))
    2100                 :          0 :     goto fail;
    2101                 :     181110 :   if (src->omp_declare_target_link
    2102                 :     181110 :       && !gfc_add_omp_declare_target_link (dest, NULL, where))
    2103                 :          0 :     goto fail;
    2104                 :     181110 :   if (src->oacc_declare_create
    2105                 :     181110 :       && !gfc_add_oacc_declare_create (dest, NULL, where))
    2106                 :          0 :     goto fail;
    2107                 :     181110 :   if (src->oacc_declare_copyin
    2108                 :     181110 :       && !gfc_add_oacc_declare_copyin (dest, NULL, where))
    2109                 :          0 :     goto fail;
    2110                 :     181110 :   if (src->oacc_declare_deviceptr
    2111                 :     181110 :       && !gfc_add_oacc_declare_deviceptr (dest, NULL, where))
    2112                 :          0 :     goto fail;
    2113                 :     181110 :   if (src->oacc_declare_device_resident
    2114                 :     181110 :       && !gfc_add_oacc_declare_device_resident (dest, NULL, where))
    2115                 :          0 :     goto fail;
    2116                 :     181110 :   if (src->target && !gfc_add_target (dest, where))
    2117                 :          1 :     goto fail;
    2118                 :     181109 :   if (src->dummy && !gfc_add_dummy (dest, NULL, where))
    2119                 :          0 :     goto fail;
    2120                 :     181109 :   if (src->result && !gfc_add_result (dest, NULL, where))
    2121                 :          0 :     goto fail;
    2122                 :     181109 :   if (src->entry)
    2123                 :          0 :     dest->entry = 1;
    2124                 :            : 
    2125                 :     181109 :   if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
    2126                 :          0 :     goto fail;
    2127                 :            : 
    2128                 :     181109 :   if (src->in_common && !gfc_add_in_common (dest, NULL, where))
    2129                 :          0 :     goto fail;
    2130                 :            : 
    2131                 :     181109 :   if (src->generic && !gfc_add_generic (dest, NULL, where))
    2132                 :          0 :     goto fail;
    2133                 :     181109 :   if (src->function && !gfc_add_function (dest, NULL, where))
    2134                 :          0 :     goto fail;
    2135                 :     181109 :   if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
    2136                 :          0 :     goto fail;
    2137                 :            : 
    2138                 :     181109 :   if (src->sequence && !gfc_add_sequence (dest, NULL, where))
    2139                 :          0 :     goto fail;
    2140                 :     181109 :   if (src->elemental && !gfc_add_elemental (dest, where))
    2141                 :          0 :     goto fail;
    2142                 :     181109 :   if (src->pure && !gfc_add_pure (dest, where))
    2143                 :          0 :     goto fail;
    2144                 :     181109 :   if (src->recursive && !gfc_add_recursive (dest, where))
    2145                 :          0 :     goto fail;
    2146                 :            : 
    2147                 :     181109 :   if (src->flavor != FL_UNKNOWN
    2148                 :     181109 :       && !gfc_add_flavor (dest, src->flavor, NULL, where))
    2149                 :        289 :     goto fail;
    2150                 :            : 
    2151                 :     180820 :   if (src->intent != INTENT_UNKNOWN
    2152                 :     180820 :       && !gfc_add_intent (dest, src->intent, where))
    2153                 :          0 :     goto fail;
    2154                 :            : 
    2155                 :     180820 :   if (src->access != ACCESS_UNKNOWN
    2156                 :     180820 :       && !gfc_add_access (dest, src->access, NULL, where))
    2157                 :          1 :     goto fail;
    2158                 :            : 
    2159                 :     180819 :   if (!gfc_missing_attr (dest, where))
    2160                 :          0 :     goto fail;
    2161                 :            : 
    2162                 :     180819 :   if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
    2163                 :          0 :     goto fail;
    2164                 :     180819 :   if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
    2165                 :          0 :     goto fail;
    2166                 :            : 
    2167                 :     180819 :   is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
    2168                 :     180819 :   if (src->is_bind_c
    2169                 :     180819 :       && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
    2170                 :            :     return false;
    2171                 :            : 
    2172                 :     180818 :   if (src->is_c_interop)
    2173                 :          0 :     dest->is_c_interop = 1;
    2174                 :     180818 :   if (src->is_iso_c)
    2175                 :          0 :     dest->is_iso_c = 1;
    2176                 :            : 
    2177                 :     180818 :   if (src->external && !gfc_add_external (dest, where))
    2178                 :          5 :     goto fail;
    2179                 :     180813 :   if (src->intrinsic && !gfc_add_intrinsic (dest, where))
    2180                 :          4 :     goto fail;
    2181                 :     180809 :   if (src->proc_pointer)
    2182                 :        382 :     dest->proc_pointer = 1;
    2183                 :            : 
    2184                 :            :   return true;
    2185                 :            : 
    2186                 :            : fail:
    2187                 :            :   return false;
    2188                 :            : }
    2189                 :            : 
    2190                 :            : 
    2191                 :            : /* A function to generate a dummy argument symbol using that from the
    2192                 :            :    interface declaration. Can be used for the result symbol as well if
    2193                 :            :    the flag is set.  */
    2194                 :            : 
    2195                 :            : int
    2196                 :        180 : gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
    2197                 :            : {
    2198                 :        180 :   int rc;
    2199                 :            : 
    2200                 :        180 :   rc = gfc_get_symbol (sym->name, NULL, dsym);
    2201                 :        180 :   if (rc)
    2202                 :            :     return rc;
    2203                 :            : 
    2204                 :        180 :   if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
    2205                 :            :     return 1;
    2206                 :            : 
    2207                 :        180 :   if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
    2208                 :            :       &gfc_current_locus))
    2209                 :            :     return 1;
    2210                 :            : 
    2211                 :        180 :   if ((*dsym)->attr.dimension)
    2212                 :         35 :     (*dsym)->as = gfc_copy_array_spec (sym->as);
    2213                 :            : 
    2214                 :        180 :   (*dsym)->attr.class_ok = sym->attr.class_ok;
    2215                 :            : 
    2216                 :        180 :   if ((*dsym) != NULL && !result
    2217                 :        165 :       && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL)
    2218                 :        165 :           || !gfc_missing_attr (&(*dsym)->attr, NULL)))
    2219                 :          0 :     return 1;
    2220                 :        180 :   else if ((*dsym) != NULL && result
    2221                 :        195 :       && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL)
    2222                 :         15 :           || !gfc_missing_attr (&(*dsym)->attr, NULL)))
    2223                 :          0 :     return 1;
    2224                 :            : 
    2225                 :            :   return 0;
    2226                 :            : }
    2227                 :            : 
    2228                 :            : 
    2229                 :            : /************** Component name management ************/
    2230                 :            : 
    2231                 :            : /* Component names of a derived type form their own little namespaces
    2232                 :            :    that are separate from all other spaces.  The space is composed of
    2233                 :            :    a singly linked list of gfc_component structures whose head is
    2234                 :            :    located in the parent symbol.  */
    2235                 :            : 
    2236                 :            : 
    2237                 :            : /* Add a component name to a symbol.  The call fails if the name is
    2238                 :            :    already present.  On success, the component pointer is modified to
    2239                 :            :    point to the additional component structure.  */
    2240                 :            : 
    2241                 :            : bool
    2242                 :      77877 : gfc_add_component (gfc_symbol *sym, const char *name,
    2243                 :            :                    gfc_component **component)
    2244                 :            : {
    2245                 :      77877 :   gfc_component *p, *tail;
    2246                 :            : 
    2247                 :            :   /* Check for existing components with the same name, but not for union
    2248                 :            :      components or containers. Unions and maps are anonymous so they have
    2249                 :            :      unique internal names which will never conflict.
    2250                 :            :      Don't use gfc_find_component here because it calls gfc_use_derived,
    2251                 :            :      but the derived type may not be fully defined yet. */
    2252                 :      77877 :   tail = NULL;
    2253                 :            : 
    2254                 :     257212 :   for (p = sym->components; p; p = p->next)
    2255                 :            :     {
    2256                 :     179339 :       if (strcmp (p->name, name) == 0)
    2257                 :            :         {
    2258                 :          4 :           gfc_error ("Component %qs at %C already declared at %L",
    2259                 :            :                      name, &p->loc);
    2260                 :          4 :           return false;
    2261                 :            :         }
    2262                 :            : 
    2263                 :     179335 :       tail = p;
    2264                 :            :     }
    2265                 :            : 
    2266                 :      77873 :   if (sym->attr.extension
    2267                 :       1054 :         && gfc_find_component (sym->components->ts.u.derived,
    2268                 :      77873 :                                name, true, true, NULL))
    2269                 :            :     {
    2270                 :          2 :       gfc_error ("Component %qs at %C already in the parent type "
    2271                 :          2 :                  "at %L", name, &sym->components->ts.u.derived->declared_at);
    2272                 :          2 :       return false;
    2273                 :            :     }
    2274                 :            : 
    2275                 :            :   /* Allocate a new component.  */
    2276                 :      77871 :   p = gfc_get_component ();
    2277                 :            : 
    2278                 :      77871 :   if (tail == NULL)
    2279                 :      23456 :     sym->components = p;
    2280                 :            :   else
    2281                 :      54415 :     tail->next = p;
    2282                 :            : 
    2283                 :      77871 :   p->name = gfc_get_string ("%s", name);
    2284                 :      77871 :   p->loc = gfc_current_locus;
    2285                 :      77871 :   p->ts.type = BT_UNKNOWN;
    2286                 :            : 
    2287                 :      77871 :   *component = p;
    2288                 :      77871 :   return true;
    2289                 :            : }
    2290                 :            : 
    2291                 :            : 
    2292                 :            : /* Recursive function to switch derived types of all symbol in a
    2293                 :            :    namespace.  */
    2294                 :            : 
    2295                 :            : static void
    2296                 :          0 : switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
    2297                 :            : {
    2298                 :          0 :   gfc_symbol *sym;
    2299                 :            : 
    2300                 :          0 :   if (st == NULL)
    2301                 :          0 :     return;
    2302                 :            : 
    2303                 :          0 :   sym = st->n.sym;
    2304                 :          0 :   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
    2305                 :          0 :     sym->ts.u.derived = to;
    2306                 :            : 
    2307                 :          0 :   switch_types (st->left, from, to);
    2308                 :          0 :   switch_types (st->right, from, to);
    2309                 :            : }
    2310                 :            : 
    2311                 :            : 
    2312                 :            : /* This subroutine is called when a derived type is used in order to
    2313                 :            :    make the final determination about which version to use.  The
    2314                 :            :    standard requires that a type be defined before it is 'used', but
    2315                 :            :    such types can appear in IMPLICIT statements before the actual
    2316                 :            :    definition.  'Using' in this context means declaring a variable to
    2317                 :            :    be that type or using the type constructor.
    2318                 :            : 
    2319                 :            :    If a type is used and the components haven't been defined, then we
    2320                 :            :    have to have a derived type in a parent unit.  We find the node in
    2321                 :            :    the other namespace and point the symtree node in this namespace to
    2322                 :            :    that node.  Further reference to this name point to the correct
    2323                 :            :    node.  If we can't find the node in a parent namespace, then we have
    2324                 :            :    an error.
    2325                 :            : 
    2326                 :            :    This subroutine takes a pointer to a symbol node and returns a
    2327                 :            :    pointer to the translated node or NULL for an error.  Usually there
    2328                 :            :    is no translation and we return the node we were passed.  */
    2329                 :            : 
    2330                 :            : gfc_symbol *
    2331                 :     223878 : gfc_use_derived (gfc_symbol *sym)
    2332                 :            : {
    2333                 :     223878 :   gfc_symbol *s;
    2334                 :     223878 :   gfc_typespec *t;
    2335                 :     223878 :   gfc_symtree *st;
    2336                 :     223878 :   int i;
    2337                 :            : 
    2338                 :     223878 :   if (!sym)
    2339                 :            :     return NULL;
    2340                 :            : 
    2341                 :     223874 :   if (sym->attr.unlimited_polymorphic)
    2342                 :            :     return sym;
    2343                 :            : 
    2344                 :     223188 :   if (sym->attr.generic)
    2345                 :          0 :     sym = gfc_find_dt_in_generic (sym);
    2346                 :            : 
    2347                 :     223188 :   if (sym->components != NULL || sym->attr.zero_comp)
    2348                 :            :     return sym;               /* Already defined.  */
    2349                 :            : 
    2350                 :         18 :   if (sym->ns->parent == NULL)
    2351                 :          9 :     goto bad;
    2352                 :            : 
    2353                 :          9 :   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
    2354                 :            :     {
    2355                 :          0 :       gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
    2356                 :          0 :       return NULL;
    2357                 :            :     }
    2358                 :            : 
    2359                 :          9 :   if (s == NULL || !gfc_fl_struct (s->attr.flavor))
    2360                 :          9 :     goto bad;
    2361                 :            : 
    2362                 :            :   /* Get rid of symbol sym, translating all references to s.  */
    2363                 :          0 :   for (i = 0; i < GFC_LETTERS; i++)
    2364                 :            :     {
    2365                 :          0 :       t = &sym->ns->default_type[i];
    2366                 :          0 :       if (t->u.derived == sym)
    2367                 :          0 :         t->u.derived = s;
    2368                 :            :     }
    2369                 :            : 
    2370                 :          0 :   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
    2371                 :          0 :   st->n.sym = s;
    2372                 :            : 
    2373                 :          0 :   s->refs++;
    2374                 :            : 
    2375                 :            :   /* Unlink from list of modified symbols.  */
    2376                 :          0 :   gfc_commit_symbol (sym);
    2377                 :            : 
    2378                 :          0 :   switch_types (sym->ns->sym_root, sym, s);
    2379                 :            : 
    2380                 :            :   /* TODO: Also have to replace sym -> s in other lists like
    2381                 :            :      namelists, common lists and interface lists.  */
    2382                 :          0 :   gfc_free_symbol (sym);
    2383                 :            : 
    2384                 :          0 :   return s;
    2385                 :            : 
    2386                 :         18 : bad:
    2387                 :         18 :   gfc_error ("Derived type %qs at %C is being used before it is defined",
    2388                 :            :              sym->name);
    2389                 :         18 :   return NULL;
    2390                 :            : }
    2391                 :            : 
    2392                 :            : 
    2393                 :            : /* Find the component with the given name in the union type symbol.
    2394                 :            :    If ref is not NULL it will be set to the chain of components through which
    2395                 :            :    the component can actually be accessed. This is necessary for unions because
    2396                 :            :    intermediate structures may be maps, nested structures, or other unions,
    2397                 :            :    all of which may (or must) be 'anonymous' to user code.  */
    2398                 :            : 
    2399                 :            : static gfc_component *
    2400                 :       2192 : find_union_component (gfc_symbol *un, const char *name,
    2401                 :            :                       bool noaccess, gfc_ref **ref)
    2402                 :            : {
    2403                 :       2192 :   gfc_component *m, *check;
    2404                 :       2192 :   gfc_ref *sref, *tmp;
    2405                 :            : 
    2406                 :       3983 :   for (m = un->components; m; m = m->next)
    2407                 :            :     {
    2408                 :       3483 :       check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
    2409                 :       3483 :       if (check == NULL)
    2410                 :       1791 :         continue;
    2411                 :            : 
    2412                 :            :       /* Found component somewhere in m; chain the refs together.  */
    2413                 :       1692 :       if (ref)
    2414                 :            :         {
    2415                 :            :           /* Map ref. */
    2416                 :       1692 :           sref = gfc_get_ref ();
    2417                 :       1692 :           sref->type = REF_COMPONENT;
    2418                 :       1692 :           sref->u.c.component = m;
    2419                 :       1692 :           sref->u.c.sym = m->ts.u.derived;
    2420                 :       1692 :           sref->next = tmp;
    2421                 :            : 
    2422                 :       1692 :           *ref = sref;
    2423                 :            :         }
    2424                 :            :       /* Other checks (such as access) were done in the recursive calls.  */
    2425                 :            :       return check;
    2426                 :            :     }
    2427                 :            :   return NULL;
    2428                 :            : }
    2429                 :            : 
    2430                 :            : 
    2431                 :            : /* Recursively append candidate COMPONENT structures to CANDIDATES.  Store
    2432                 :            :    the number of total candidates in CANDIDATES_LEN.  */
    2433                 :            : 
    2434                 :            : static void
    2435                 :         33 : lookup_component_fuzzy_find_candidates (gfc_component *component,
    2436                 :            :                                         char **&candidates,
    2437                 :            :                                         size_t &candidates_len)
    2438                 :            : {
    2439                 :         78 :   for (gfc_component *p = component; p; p = p->next)
    2440                 :         45 :     vec_push (candidates, candidates_len, p->name);
    2441                 :          0 : }
    2442                 :            : 
    2443                 :            : 
    2444                 :            : /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account.  */
    2445                 :            : 
    2446                 :            : static const char*
    2447                 :         33 : lookup_component_fuzzy (const char *member, gfc_component *component)
    2448                 :            : {
    2449                 :         33 :   char **candidates = NULL;
    2450                 :         33 :   size_t candidates_len = 0;
    2451                 :         33 :   lookup_component_fuzzy_find_candidates (component, candidates,
    2452                 :            :                                           candidates_len);
    2453                 :         33 :   return gfc_closest_fuzzy_match (member, candidates);
    2454                 :            : }
    2455                 :            : 
    2456                 :            : 
    2457                 :            : /* Given a derived type node and a component name, try to locate the
    2458                 :            :    component structure.  Returns the NULL pointer if the component is
    2459                 :            :    not found or the components are private.  If noaccess is set, no access
    2460                 :            :    checks are done.  If silent is set, an error will not be generated if
    2461                 :            :    the component cannot be found or accessed.
    2462                 :            : 
    2463                 :            :    If ref is not NULL, *ref is set to represent the chain of components
    2464                 :            :    required to get to the ultimate component.
    2465                 :            : 
    2466                 :            :    If the component is simply a direct subcomponent, or is inherited from a
    2467                 :            :    parent derived type in the given derived type, this is a single ref with its
    2468                 :            :    component set to the returned component.
    2469                 :            : 
    2470                 :            :    Otherwise, *ref is constructed as a chain of subcomponents. This occurs
    2471                 :            :    when the component is found through an implicit chain of nested union and
    2472                 :            :    map components. Unions and maps are "anonymous" substructures in FORTRAN
    2473                 :            :    which cannot be explicitly referenced, but the reference chain must be
    2474                 :            :    considered as in C for backend translation to correctly compute layouts.
    2475                 :            :    (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a).  */
    2476                 :            : 
    2477                 :            : gfc_component *
    2478                 :     212128 : gfc_find_component (gfc_symbol *sym, const char *name,
    2479                 :            :                     bool noaccess, bool silent, gfc_ref **ref)
    2480                 :            : {
    2481                 :     212128 :   gfc_component *p, *check;
    2482                 :     212128 :   gfc_ref *sref = NULL, *tmp = NULL;
    2483                 :            : 
    2484                 :     212128 :   if (name == NULL || sym == NULL)
    2485                 :            :     return NULL;
    2486                 :            : 
    2487                 :     207138 :   if (sym->attr.flavor == FL_DERIVED)
    2488                 :     198378 :     sym = gfc_use_derived (sym);
    2489                 :            :   else
    2490                 :       8760 :     gcc_assert (gfc_fl_struct (sym->attr.flavor));
    2491                 :            : 
    2492                 :     207138 :   if (sym == NULL)
    2493                 :            :     return NULL;
    2494                 :            : 
    2495                 :            :   /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
    2496                 :     207136 :   if (sym->attr.flavor == FL_UNION)
    2497                 :        500 :     return find_union_component (sym, name, noaccess, ref);
    2498                 :            : 
    2499                 :     206636 :   if (ref) *ref = NULL;
    2500                 :     444799 :   for (p = sym->components; p; p = p->next)
    2501                 :            :     {
    2502                 :            :       /* Nest search into union's maps. */
    2503                 :     417652 :       if (p->ts.type == BT_UNION)
    2504                 :            :         {
    2505                 :       1692 :           check = find_union_component (p->ts.u.derived, name, noaccess, &tmp);
    2506                 :       1692 :           if (check != NULL)
    2507                 :            :             {
    2508                 :            :               /* Union ref. */
    2509                 :       1692 :               if (ref)
    2510                 :            :                 {
    2511                 :       1252 :                   sref = gfc_get_ref ();
    2512                 :       1252 :                   sref->type = REF_COMPONENT;
    2513                 :       1252 :                   sref->u.c.component = p;
    2514                 :       1252 :                   sref->u.c.sym = p->ts.u.derived;
    2515                 :       1252 :                   sref->next = tmp;
    2516                 :       1252 :                   *ref = sref;
    2517                 :            :                 }
    2518                 :       1692 :               return check;
    2519                 :            :             }
    2520                 :            :         }
    2521                 :     415960 :       else if (strcmp (p->name, name) == 0)
    2522                 :            :         break;
    2523                 :            : 
    2524                 :     238163 :       continue;
    2525                 :            :     }
    2526                 :            : 
    2527                 :     204944 :   if (p && sym->attr.use_assoc && !noaccess)
    2528                 :            :     {
    2529                 :      22171 :       bool is_parent_comp = sym->attr.extension && (p == sym->components);
    2530                 :      22171 :       if (p->attr.access == ACCESS_PRIVATE ||
    2531                 :            :           (p->attr.access != ACCESS_PUBLIC
    2532                 :      21588 :            && sym->component_access == ACCESS_PRIVATE
    2533                 :         44 :            && !is_parent_comp))
    2534                 :            :         {
    2535                 :         50 :           if (!silent)
    2536                 :         14 :             gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
    2537                 :            :                        name, sym->name);
    2538                 :         50 :           return NULL;
    2539                 :            :         }
    2540                 :            :     }
    2541                 :            : 
    2542                 :     204894 :   if (p == NULL
    2543                 :      27147 :         && sym->attr.extension
    2544                 :      18136 :         && sym->components->ts.type == BT_DERIVED)
    2545                 :            :     {
    2546                 :      18136 :       p = gfc_find_component (sym->components->ts.u.derived, name,
    2547                 :            :                               noaccess, silent, ref);
    2548                 :            :       /* Do not overwrite the error.  */
    2549                 :      18136 :       if (p == NULL)
    2550                 :            :         return p;
    2551                 :            :     }
    2552                 :            : 
    2553                 :     204506 :   if (p == NULL && !silent)
    2554                 :            :     {
    2555                 :         33 :       const char *guessed = lookup_component_fuzzy (name, sym->components);
    2556                 :         33 :       if (guessed)
    2557                 :         10 :         gfc_error ("%qs at %C is not a member of the %qs structure"
    2558                 :            :                    "; did you mean %qs?",
    2559                 :            :                    name, sym->name, guessed);
    2560                 :            :       else
    2561                 :         23 :         gfc_error ("%qs at %C is not a member of the %qs structure",
    2562                 :            :                    name, sym->name);
    2563                 :            :     }
    2564                 :            : 
    2565                 :            :   /* Component was found; build the ultimate component reference. */
    2566                 :     204506 :   if (p != NULL && ref)
    2567                 :            :     {
    2568                 :     156175 :       tmp = gfc_get_ref ();
    2569                 :     156175 :       tmp->type = REF_COMPONENT;
    2570                 :     156175 :       tmp->u.c.component = p;
    2571                 :     156175 :       tmp->u.c.sym = sym;
    2572                 :            :       /* Link the final component ref to the end of the chain of subrefs. */
    2573                 :     156175 :       if (sref)
    2574                 :            :         {
    2575                 :            :           *ref = sref;
    2576                 :            :           for (; sref->next; sref = sref->next)
    2577                 :            :             ;
    2578                 :            :           sref->next = tmp;
    2579                 :            :         }
    2580                 :            :       else
    2581                 :     156175 :         *ref = tmp;
    2582                 :            :     }
    2583                 :            : 
    2584                 :            :   return p;
    2585                 :            : }
    2586                 :            : 
    2587                 :            : 
    2588                 :            : /* Given a symbol, free all of the component structures and everything
    2589                 :            :    they point to.  */
    2590                 :            : 
    2591                 :            : static void
    2592                 :    3567950 : free_components (gfc_component *p)
    2593                 :            : {
    2594                 :    3701580 :   gfc_component *q;
    2595                 :            : 
    2596                 :    3701580 :   for (; p; p = q)
    2597                 :            :     {
    2598                 :     133633 :       q = p->next;
    2599                 :            : 
    2600                 :     133633 :       gfc_free_array_spec (p->as);
    2601                 :     133633 :       gfc_free_expr (p->initializer);
    2602                 :     133633 :       if (p->kind_expr)
    2603                 :        108 :         gfc_free_expr (p->kind_expr);
    2604                 :     133633 :       if (p->param_list)
    2605                 :         79 :         gfc_free_actual_arglist (p->param_list);
    2606                 :     133633 :       free (p->tb);
    2607                 :            : 
    2608                 :     133633 :       free (p);
    2609                 :            :     }
    2610                 :    3567950 : }
    2611                 :            : 
    2612                 :            : 
    2613                 :            : /******************** Statement label management ********************/
    2614                 :            : 
    2615                 :            : /* Comparison function for statement labels, used for managing the
    2616                 :            :    binary tree.  */
    2617                 :            : 
    2618                 :            : static int
    2619                 :       7434 : compare_st_labels (void *a1, void *b1)
    2620                 :            : {
    2621                 :       7434 :   int a = ((gfc_st_label *) a1)->value;
    2622                 :       7434 :   int b = ((gfc_st_label *) b1)->value;
    2623                 :            : 
    2624                 :       7434 :   return (b - a);
    2625                 :            : }
    2626                 :            : 
    2627                 :            : 
    2628                 :            : /* Free a single gfc_st_label structure, making sure the tree is not
    2629                 :            :    messed up.  This function is called only when some parse error
    2630                 :            :    occurs.  */
    2631                 :            : 
    2632                 :            : void
    2633                 :          3 : gfc_free_st_label (gfc_st_label *label)
    2634                 :            : {
    2635                 :            : 
    2636                 :          3 :   if (label == NULL)
    2637                 :            :     return;
    2638                 :            : 
    2639                 :          3 :   gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
    2640                 :            : 
    2641                 :          3 :   if (label->format != NULL)
    2642                 :          0 :     gfc_free_expr (label->format);
    2643                 :            : 
    2644                 :          3 :   free (label);
    2645                 :            : }
    2646                 :            : 
    2647                 :            : 
    2648                 :            : /* Free a whole tree of gfc_st_label structures.  */
    2649                 :            : 
    2650                 :            : static void
    2651                 :     284476 : free_st_labels (gfc_st_label *label)
    2652                 :            : {
    2653                 :            : 
    2654                 :     284476 :   if (label == NULL)
    2655                 :            :     return;
    2656                 :            : 
    2657                 :       4581 :   free_st_labels (label->left);
    2658                 :       4581 :   free_st_labels (label->right);
    2659                 :            : 
    2660                 :       4581 :   if (label->format != NULL)
    2661                 :        960 :     gfc_free_expr (label->format);
    2662                 :       4581 :   free (label);
    2663                 :            : }
    2664                 :            : 
    2665                 :            : 
    2666                 :            : /* Given a label number, search for and return a pointer to the label
    2667                 :            :    structure, creating it if it does not exist.  */
    2668                 :            : 
    2669                 :            : gfc_st_label *
    2670                 :      13282 : gfc_get_st_label (int labelno)
    2671                 :            : {
    2672                 :      13282 :   gfc_st_label *lp;
    2673                 :      13282 :   gfc_namespace *ns;
    2674                 :            : 
    2675                 :      13282 :   if (gfc_current_state () == COMP_DERIVED)
    2676                 :          3 :     ns = gfc_current_block ()->f2k_derived;
    2677                 :            :   else
    2678                 :            :     {
    2679                 :            :       /* Find the namespace of the scoping unit:
    2680                 :            :          If we're in a BLOCK construct, jump to the parent namespace.  */
    2681                 :      13279 :       ns = gfc_current_ns;
    2682                 :      13287 :       while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
    2683                 :          8 :         ns = ns->parent;
    2684                 :            :     }
    2685                 :            : 
    2686                 :            :   /* First see if the label is already in this namespace.  */
    2687                 :      13282 :   lp = ns->st_labels;
    2688                 :      29848 :   while (lp)
    2689                 :            :     {
    2690                 :      25263 :       if (lp->value == labelno)
    2691                 :       8697 :         return lp;
    2692                 :            : 
    2693                 :      16566 :       if (lp->value < labelno)
    2694                 :      11821 :         lp = lp->left;
    2695                 :            :       else
    2696                 :       4745 :         lp = lp->right;
    2697                 :            :     }
    2698                 :            : 
    2699                 :       4585 :   lp = XCNEW (gfc_st_label);
    2700                 :            : 
    2701                 :       4585 :   lp->value = labelno;
    2702                 :       4585 :   lp->defined = ST_LABEL_UNKNOWN;
    2703                 :       4585 :   lp->referenced = ST_LABEL_UNKNOWN;
    2704                 :       4585 :   lp->ns = ns;
    2705                 :            : 
    2706                 :       4585 :   gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
    2707                 :            : 
    2708                 :       4585 :   return lp;
    2709                 :            : }
    2710                 :            : 
    2711                 :            : 
    2712                 :            : /* Called when a statement with a statement label is about to be
    2713                 :            :    accepted.  We add the label to the list of the current namespace,
    2714                 :            :    making sure it hasn't been defined previously and referenced
    2715                 :            :    correctly.  */
    2716                 :            : 
    2717                 :            : void
    2718                 :       4554 : gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
    2719                 :            : {
    2720                 :       4554 :   int labelno;
    2721                 :            : 
    2722                 :       4554 :   labelno = lp->value;
    2723                 :            : 
    2724                 :       4554 :   if (lp->defined != ST_LABEL_UNKNOWN)
    2725                 :          2 :     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
    2726                 :            :                &lp->where, label_locus);
    2727                 :            :   else
    2728                 :            :     {
    2729                 :       4552 :       lp->where = *label_locus;
    2730                 :            : 
    2731                 :       4552 :       switch (type)
    2732                 :            :         {
    2733                 :        960 :         case ST_LABEL_FORMAT:
    2734                 :        960 :           if (lp->referenced == ST_LABEL_TARGET
    2735                 :        960 :               || lp->referenced == ST_LABEL_DO_TARGET)
    2736                 :          0 :             gfc_error ("Label %d at %C already referenced as branch target",
    2737                 :            :                        labelno);
    2738                 :            :           else
    2739                 :        960 :             lp->defined = ST_LABEL_FORMAT;
    2740                 :            : 
    2741                 :            :           break;
    2742                 :            : 
    2743                 :       3585 :         case ST_LABEL_TARGET:
    2744                 :       3585 :         case ST_LABEL_DO_TARGET:
    2745                 :       3585 :           if (lp->referenced == ST_LABEL_FORMAT)
    2746                 :          0 :             gfc_error ("Label %d at %C already referenced as a format label",
    2747                 :            :                        labelno);
    2748                 :            :           else
    2749                 :       3585 :             lp->defined = type;
    2750                 :            : 
    2751                 :       1649 :           if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
    2752                 :       3714 :               && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
    2753                 :            :                                   "DO termination statement which is not END DO"
    2754                 :            :                                   " or CONTINUE with label %d at %C", labelno))
    2755                 :            :             return;
    2756                 :            :           break;
    2757                 :            : 
    2758                 :          7 :         default:
    2759                 :          7 :           lp->defined = ST_LABEL_BAD_TARGET;
    2760                 :          7 :           lp->referenced = ST_LABEL_BAD_TARGET;
    2761                 :            :         }
    2762                 :            :     }
    2763                 :            : }
    2764                 :            : 
    2765                 :            : 
    2766                 :            : /* Reference a label.  Given a label and its type, see if that
    2767                 :            :    reference is consistent with what is known about that label,
    2768                 :            :    updating the unknown state.  Returns false if something goes
    2769                 :            :    wrong.  */
    2770                 :            : 
    2771                 :            : bool
    2772                 :      17137 : gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
    2773                 :            : {
    2774                 :      17137 :   gfc_sl_type label_type;
    2775                 :      17137 :   int labelno;
    2776                 :      17137 :   bool rc;
    2777                 :            : 
    2778                 :      17137 :   if (lp == NULL)
    2779                 :            :     return true;
    2780                 :            : 
    2781                 :       7549 :   labelno = lp->value;
    2782                 :            : 
    2783                 :       7549 :   if (lp->defined != ST_LABEL_UNKNOWN)
    2784                 :            :     label_type = lp->defined;
    2785                 :            :   else
    2786                 :            :     {
    2787                 :       5932 :       label_type = lp->referenced;
    2788                 :       5932 :       lp->where = gfc_current_locus;
    2789                 :            :     }
    2790                 :            : 
    2791                 :       7549 :   if (label_type == ST_LABEL_FORMAT
    2792                 :       1158 :       && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
    2793                 :            :     {
    2794                 :          0 :       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
    2795                 :          0 :       rc = false;
    2796                 :          0 :       goto done;
    2797                 :            :     }
    2798                 :            : 
    2799                 :       7549 :   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
    2800                 :       7549 :        || label_type == ST_LABEL_BAD_TARGET)
    2801                 :       2401 :       && type == ST_LABEL_FORMAT)
    2802                 :            :     {
    2803                 :          0 :       gfc_error ("Label %d at %C previously used as branch target", labelno);
    2804                 :          0 :       rc = false;
    2805                 :          0 :       goto done;
    2806                 :            :     }
    2807                 :            : 
    2808                 :        615 :   if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
    2809                 :       8085 :       && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
    2810                 :            :                           "Shared DO termination label %d at %C", labelno))
    2811                 :            :     return false;
    2812                 :            : 
    2813                 :       7549 :   if (type == ST_LABEL_DO_TARGET
    2814                 :       7549 :       && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement "
    2815                 :            :                           "at %L", &gfc_current_locus))
    2816                 :            :     return false;
    2817                 :            : 
    2818                 :       7549 :   if (lp->referenced != ST_LABEL_DO_TARGET)
    2819                 :       6934 :     lp->referenced = type;
    2820                 :            :   rc = true;
    2821                 :            : 
    2822                 :            : done:
    2823                 :            :   return rc;
    2824                 :            : }
    2825                 :            : 
    2826                 :            : 
    2827                 :            : /************** Symbol table management subroutines ****************/
    2828                 :            : 
    2829                 :            : /* Basic details: Fortran 95 requires a potentially unlimited number
    2830                 :            :    of distinct namespaces when compiling a program unit.  This case
    2831                 :            :    occurs during a compilation of internal subprograms because all of
    2832                 :            :    the internal subprograms must be read before we can start
    2833                 :            :    generating code for the host.
    2834                 :            : 
    2835                 :            :    Given the tricky nature of the Fortran grammar, we must be able to
    2836                 :            :    undo changes made to a symbol table if the current interpretation
    2837                 :            :    of a statement is found to be incorrect.  Whenever a symbol is
    2838                 :            :    looked up, we make a copy of it and link to it.  All of these
    2839                 :            :    symbols are kept in a vector so that we can commit or
    2840                 :            :    undo the changes at a later time.
    2841                 :            : 
    2842                 :            :    A symtree may point to a symbol node outside of its namespace.  In
    2843                 :            :    this case, that symbol has been used as a host associated variable
    2844                 :            :    at some previous time.  */
    2845                 :            : 
    2846                 :            : /* Allocate a new namespace structure.  Copies the implicit types from
    2847                 :            :    PARENT if PARENT_TYPES is set.  */
    2848                 :            : 
    2849                 :            : gfc_namespace *
    2850                 :     307608 : gfc_get_namespace (gfc_namespace *parent, int parent_types)
    2851                 :            : {
    2852                 :     307608 :   gfc_namespace *ns;
    2853                 :     307608 :   gfc_typespec *ts;
    2854                 :     307608 :   int in;
    2855                 :     307608 :   int i;
    2856                 :            : 
    2857                 :     307608 :   ns = XCNEW (gfc_namespace);
    2858                 :     307608 :   ns->sym_root = NULL;
    2859                 :     307608 :   ns->uop_root = NULL;
    2860                 :     307608 :   ns->tb_sym_root = NULL;
    2861                 :     307608 :   ns->finalizers = NULL;
    2862                 :     307608 :   ns->default_access = ACCESS_UNKNOWN;
    2863                 :     307608 :   ns->parent = parent;
    2864                 :            : 
    2865                 :    8920630 :   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
    2866                 :            :     {
    2867                 :    8613020 :       ns->operator_access[in] = ACCESS_UNKNOWN;
    2868                 :    8613020 :       ns->tb_op[in] = NULL;
    2869                 :            :     }
    2870                 :            : 
    2871                 :            :   /* Initialize default implicit types.  */
    2872                 :    8305420 :   for (i = 'a'; i <= 'z'; i++)
    2873                 :            :     {
    2874                 :    7997810 :       ns->set_flag[i - 'a'] = 0;
    2875                 :    7997810 :       ts = &ns->default_type[i - 'a'];
    2876                 :            : 
    2877                 :    7997810 :       if (parent_types && ns->parent != NULL)
    2878                 :            :         {
    2879                 :            :           /* Copy parent settings.  */
    2880                 :    1068630 :           *ts = ns->parent->default_type[i - 'a'];
    2881                 :    1068630 :           continue;
    2882                 :            :         }
    2883                 :            : 
    2884                 :    6929180 :       if (flag_implicit_none != 0)
    2885                 :            :         {
    2886                 :      81692 :           gfc_clear_ts (ts);
    2887                 :      81692 :           continue;
    2888                 :            :         }
    2889                 :            : 
    2890                 :    6847490 :       if ('i' <= i && i <= 'n')
    2891                 :            :         {
    2892                 :    1580190 :           ts->type = BT_INTEGER;
    2893                 :    1580190 :           ts->kind = gfc_default_integer_kind;
    2894                 :            :         }
    2895                 :            :       else
    2896                 :            :         {
    2897                 :    5267300 :           ts->type = BT_REAL;
    2898                 :    5267300 :           ts->kind = gfc_default_real_kind;
    2899                 :            :         }
    2900                 :            :     }
    2901                 :            : 
    2902                 :     307608 :   ns->refs = 1;
    2903                 :            : 
    2904                 :     307608 :   return ns;
    2905                 :            : }
    2906                 :            : 
    2907                 :            : 
    2908                 :            : /* Comparison function for symtree nodes.  */
    2909                 :            : 
    2910                 :            : static int
    2911                 :   19290700 : compare_symtree (void *_st1, void *_st2)
    2912                 :            : {
    2913                 :   19290700 :   gfc_symtree *st1, *st2;
    2914                 :            : 
    2915                 :   19290700 :   st1 = (gfc_symtree *) _st1;
    2916                 :   19290700 :   st2 = (gfc_symtree *) _st2;
    2917                 :            : 
    2918                 :   19290700 :   return strcmp (st1->name, st2->name);
    2919                 :            : }
    2920                 :            : 
    2921                 :            : 
    2922                 :            : /* Allocate a new symtree node and associate it with the new symbol.  */
    2923                 :            : 
    2924                 :            : gfc_symtree *
    2925                 :    3715420 : gfc_new_symtree (gfc_symtree **root, const char *name)
    2926                 :            : {
    2927                 :    3715420 :   gfc_symtree *st;
    2928                 :            : 
    2929                 :    3715420 :   st = XCNEW (gfc_symtree);
    2930                 :    3715420 :   st->name = gfc_get_string ("%s", name);
    2931                 :            : 
    2932                 :    3715420 :   gfc_insert_bbt (root, st, compare_symtree);
    2933                 :    3715420 :   return st;
    2934                 :            : }
    2935                 :            : 
    2936                 :            : 
    2937                 :            : /* Delete a symbol from the tree.  Does not free the symbol itself!  */
    2938                 :            : 
    2939                 :            : void
    2940                 :    2702120 : gfc_delete_symtree (gfc_symtree **root, const char *name)
    2941                 :            : {
    2942                 :    2702120 :   gfc_symtree st, *st0;
    2943                 :    2702120 :   const char *p;
    2944                 :            : 
    2945                 :            :   /* Submodules are marked as mod.submod.  When freeing a submodule
    2946                 :            :      symbol, the symtree only has "submod", so adjust that here.  */
    2947                 :            : 
    2948                 :    2702120 :   p = strrchr(name, '.');
    2949                 :    2702120 :   if (p)
    2950                 :          0 :     p++;
    2951                 :            :   else
    2952                 :            :     p = name;
    2953                 :            : 
    2954                 :    2702120 :   st0 = gfc_find_symtree (*root, p);
    2955                 :            : 
    2956                 :    2702120 :   st.name = gfc_get_string ("%s", p);
    2957                 :    2702120 :   gfc_delete_bbt (root, &st, compare_symtree);
    2958                 :            : 
    2959                 :    2702120 :   free (st0);
    2960                 :    2702120 : }
    2961                 :            : 
    2962                 :            : 
    2963                 :            : /* Given a root symtree node and a name, try to find the symbol within
    2964                 :            :    the namespace.  Returns NULL if the symbol is not found.  */
    2965                 :            : 
    2966                 :            : gfc_symtree *
    2967                 :   19677600 : gfc_find_symtree (gfc_symtree *st, const char *name)
    2968                 :            : {
    2969                 :   77109700 :   int c;
    2970                 :            : 
    2971                 :   77109700 :   while (st != NULL)
    2972                 :            :     {
    2973                 :   67182300 :       c = strcmp (name, st->name);
    2974                 :   67182300 :       if (c == 0)
    2975                 :    9750210 :         return st;
    2976                 :            : 
    2977                 :   57432100 :       st = (c < 0) ? st->left : st->right;
    2978                 :            :     }
    2979                 :            : 
    2980                 :            :   return NULL;
    2981                 :            : }
    2982                 :            : 
    2983                 :            : 
    2984                 :            : /* Return a symtree node with a name that is guaranteed to be unique
    2985                 :            :    within the namespace and corresponds to an illegal fortran name.  */
    2986                 :            : 
    2987                 :            : gfc_symtree *
    2988                 :     219041 : gfc_get_unique_symtree (gfc_namespace *ns)
    2989                 :            : {
    2990                 :     219041 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2991                 :     219041 :   static int serial = 0;
    2992                 :            : 
    2993                 :     219041 :   sprintf (name, "@%d", serial++);
    2994                 :     219041 :   return gfc_new_symtree (&ns->sym_root, name);
    2995                 :            : }
    2996                 :            : 
    2997                 :            : 
    2998                 :            : /* Given a name find a user operator node, creating it if it doesn't
    2999                 :            :    exist.  These are much simpler than symbols because they can't be
    3000                 :            :    ambiguous with one another.  */
    3001                 :            : 
    3002                 :            : gfc_user_op *
    3003                 :        652 : gfc_get_uop (const char *name)
    3004                 :            : {
    3005                 :        652 :   gfc_user_op *uop;
    3006                 :        652 :   gfc_symtree *st;
    3007                 :        652 :   gfc_namespace *ns = gfc_current_ns;
    3008                 :            : 
    3009                 :        652 :   if (ns->omp_udr_ns)
    3010                 :         35 :     ns = ns->parent;
    3011                 :        652 :   st = gfc_find_symtree (ns->uop_root, name);
    3012                 :        652 :   if (st != NULL)
    3013                 :        382 :     return st->n.uop;
    3014                 :            : 
    3015                 :        270 :   st = gfc_new_symtree (&ns->uop_root, name);
    3016                 :            : 
    3017                 :        270 :   uop = st->n.uop = XCNEW (gfc_user_op);
    3018                 :        270 :   uop->name = gfc_get_string ("%s", name);
    3019                 :        270 :   uop->access = ACCESS_UNKNOWN;
    3020                 :        270 :   uop->ns = ns;
    3021                 :            : 
    3022                 :        270 :   return uop;
    3023                 :            : }
    3024                 :            : 
    3025                 :            : 
    3026                 :            : /* Given a name find the user operator node.  Returns NULL if it does
    3027                 :            :    not exist.  */
    3028                 :            : 
    3029                 :            : gfc_user_op *
    3030                 :       6657 : gfc_find_uop (const char *name, gfc_namespace *ns)
    3031                 :            : {
    3032                 :       6657 :   gfc_symtree *st;
    3033                 :            : 
    3034                 :       6657 :   if (ns == NULL)
    3035                 :         18 :     ns = gfc_current_ns;
    3036                 :            : 
    3037                 :       6657 :   st = gfc_find_symtree (ns->uop_root, name);
    3038                 :       6657 :   return (st == NULL) ? NULL : st->n.uop;
    3039                 :            : }
    3040                 :            : 
    3041                 :            : 
    3042                 :            : /* Update a symbol's common_block field, and take care of the associated
    3043                 :            :    memory management.  */
    3044                 :            : 
    3045                 :            : static void
    3046                 :    4375720 : set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
    3047                 :            : {
    3048                 :    4375720 :   if (sym->common_block == common_block)
    3049                 :            :     return;
    3050                 :            : 
    3051                 :       5754 :   if (sym->common_block && sym->common_block->name[0] != '\0')
    3052                 :            :     {
    3053                 :       5390 :       sym->common_block->refs--;
    3054                 :       5390 :       if (sym->common_block->refs == 0)
    3055                 :       1701 :         free (sym->common_block);
    3056                 :            :     }
    3057                 :       5754 :   sym->common_block = common_block;
    3058                 :            : }
    3059                 :            : 
    3060                 :            : 
    3061                 :            : /* Remove a gfc_symbol structure and everything it points to.  */
    3062                 :            : 
    3063                 :            : void
    3064                 :    3667050 : gfc_free_symbol (gfc_symbol *sym)
    3065                 :            : {
    3066                 :            : 
    3067                 :    3667050 :   if (sym == NULL)
    3068                 :            :     return;
    3069                 :            : 
    3070                 :    3567950 :   gfc_free_array_spec (sym->as);
    3071                 :            : 
    3072                 :    3567950 :   free_components (sym->components);
    3073                 :            : 
    3074                 :    3567950 :   gfc_free_expr (sym->value);
    3075                 :            : 
    3076                 :    3567950 :   gfc_free_namelist (sym->namelist);
    3077                 :            : 
    3078                 :    3567950 :   if (sym->ns != sym->formal_ns)
    3079                 :    3533960 :     gfc_free_namespace (sym->formal_ns);
    3080                 :            : 
    3081                 :    3567950 :   if (!sym->attr.generic_copy)
    3082                 :    3567950 :     gfc_free_interface (sym->generic);
    3083                 :            : 
    3084                 :    3567950 :   gfc_free_formal_arglist (sym->formal);
    3085                 :            : 
    3086                 :    3567950 :   gfc_free_namespace (sym->f2k_derived);
    3087                 :            : 
    3088                 :    3567950 :   set_symbol_common_block (sym, NULL);
    3089                 :            : 
    3090                 :    3567950 :   if (sym->param_list)
    3091                 :        632 :     gfc_free_actual_arglist (sym->param_list);
    3092                 :            : 
    3093                 :    3567950 :   free (sym);
    3094                 :            : }
    3095                 :            : 
    3096                 :            : 
    3097                 :            : /* Decrease the reference counter and free memory when we reach zero.  */
    3098                 :            : 
    3099                 :            : void
    3100                 :    3570150 : gfc_release_symbol (gfc_symbol *sym)
    3101                 :            : {
    3102                 :    3570150 :   if (sym == NULL)
    3103                 :            :     return;
    3104                 :            : 
    3105                 :    3569960 :   if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
    3106                 :      19487 :       && (!sym->attr.entry || !sym->module))
    3107                 :            :     {
    3108                 :            :       /* As formal_ns contains a reference to sym, delete formal_ns just
    3109                 :            :          before the deletion of sym.  */
    3110                 :      19429 :       gfc_namespace *ns = sym->formal_ns;
    3111                 :      19429 :       sym->formal_ns = NULL;
    3112                 :      19429 :       gfc_free_namespace (ns);
    3113                 :            :     }
    3114                 :            : 
    3115                 :    3569960 :   sym->refs--;
    3116                 :    3569960 :   if (sym->refs > 0)
    3117                 :            :     return;
    3118                 :            : 
    3119                 :    3525790 :   gcc_assert (sym->refs == 0);
    3120                 :    3525790 :   gfc_free_symbol (sym);
    3121                 :            : }
    3122                 :            : 
    3123                 :            : 
    3124                 :            : /* Allocate and initialize a new symbol node.  */
    3125                 :            : 
    3126                 :            : gfc_symbol *
    3127                 :    3682050 : gfc_new_symbol (const char *name, gfc_namespace *ns)
    3128                 :            : {
    3129                 :    3682050 :   gfc_symbol *p;
    3130                 :            : 
    3131                 :    3682050 :   p = XCNEW (gfc_symbol);
    3132                 :            : 
    3133                 :    3682050 :   gfc_clear_ts (&p->ts);
    3134                 :    3682050 :   gfc_clear_attr (&p->attr);
    3135                 :    3682050 :   p->ns = ns;
    3136                 :    3682050 :   p->declared_at = gfc_current_locus;
    3137                 :    3682050 :   p->name = gfc_get_string ("%s", name);
    3138                 :            : 
    3139                 :    3682050 :   return p;
    3140                 :            : }
    3141                 :            : 
    3142                 :            : 
    3143                 :            : /* Generate an error if a symbol is ambiguous.  */
    3144                 :            : 
    3145                 :            : static void
    3146                 :         19 : ambiguous_symbol (const char *name, gfc_symtree *st)
    3147                 :            : {
    3148                 :            : 
    3149                 :         19 :   if (st->n.sym->module)
    3150                 :         14 :     gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
    3151                 :            :                "from module %qs", name, st->n.sym->name, st->n.sym->module);
    3152                 :            :   else
    3153                 :          5 :     gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
    3154                 :            :                "from current program unit", name, st->n.sym->name);
    3155                 :         19 : }
    3156                 :            : 
    3157                 :            : 
    3158                 :            : /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
    3159                 :            :    selector on the stack. If yes, replace it by the corresponding temporary.  */
    3160                 :            : 
    3161                 :            : static void
    3162                 :          0 : select_type_insert_tmp (gfc_symtree **st)
    3163                 :            : {
    3164                 :          0 :   gfc_select_type_stack *stack = select_type_stack;
    3165                 :    6340730 :   for (; stack; stack = stack->prev)
    3166                 :      78120 :     if ((*st)->n.sym == stack->selector && stack->tmp)
    3167                 :            :       {
    3168                 :          0 :         *st = stack->tmp;
    3169                 :          0 :         select_type_insert_tmp (st);
    3170                 :          0 :         return;
    3171                 :            :       }
    3172                 :            : }
    3173                 :            : 
    3174                 :            : 
    3175                 :            : /* Look for a symtree in the current procedure -- that is, go up to
    3176                 :            :    parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
    3177                 :            : 
    3178                 :            : gfc_symtree*
    3179                 :        180 : gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
    3180                 :            : {
    3181                 :        224 :   while (ns)
    3182                 :            :     {
    3183                 :        224 :       gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
    3184                 :        224 :       if (st)
    3185                 :        178 :         return st;
    3186                 :            : 
    3187                 :         46 :       if (!ns->construct_entities)
    3188                 :            :         break;
    3189                 :         44 :       ns = ns->parent;
    3190                 :            :     }
    3191                 :            : 
    3192                 :            :   return NULL;
    3193                 :            : }
    3194                 :            : 
    3195                 :            : 
    3196                 :            : /* Search for a symtree starting in the current namespace, resorting to
    3197                 :            :    any parent namespaces if requested by a nonzero parent_flag.
    3198                 :            :    Returns nonzero if the name is ambiguous.  */
    3199                 :            : 
    3200                 :            : int
    3201                 :   10894500 : gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
    3202                 :            :                    gfc_symtree **result)
    3203                 :            : {
    3204                 :   10894500 :   gfc_symtree *st;
    3205                 :            : 
    3206                 :   10894500 :   if (ns == NULL)
    3207                 :    4007700 :     ns = gfc_current_ns;
    3208                 :            : 
    3209                 :   11986000 :   do
    3210                 :            :     {
    3211                 :   11986000 :       st = gfc_find_symtree (ns->sym_root, name);
    3212                 :   11986000 :       if (st != NULL)
    3213                 :            :         {
    3214                 :    6279120 :           select_type_insert_tmp (&st);
    3215                 :            : 
    3216                 :    6262610 :           *result = st;
    3217                 :            :           /* Ambiguous generic interfaces are permitted, as long
    3218                 :            :              as the specific interfaces are different.  */
    3219                 :    6262610 :           if (st->ambiguous && !st->n.sym->attr.generic)
    3220                 :            :             {
    3221                 :         15 :               ambiguous_symbol (name, st);
    3222                 :         15 :               return 1;
    3223                 :            :             }
    3224                 :            : 
    3225                 :            :           return 0;
    3226                 :            :         }
    3227                 :            : 
    3228                 :    5723430 :       if (!parent_flag)
    3229                 :            :         break;
    3230                 :            : 
    3231                 :            :       /* Don't escape an interface block.  */
    3232                 :    3937250 :       if (ns && !ns->has_import_set
    3233                 :    3931350 :           && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
    3234                 :            :         break;
    3235                 :            : 
    3236                 :    3843160 :       ns = ns->parent;
    3237                 :            :     }
    3238                 :    3843160 :   while (ns != NULL);
    3239                 :            : 
    3240                 :    4631860 :   if (gfc_current_state() == COMP_DERIVED
    3241                 :     137015 :       && gfc_current_block ()->attr.pdt_template)
    3242                 :            :     {
    3243                 :            :       gfc_symbol *der = gfc_current_block ();
    3244                 :       9636 :       for (; der; der = gfc_get_derived_super_type (der))
    3245                 :            :         {
    3246                 :       5498 :           if (der->f2k_derived && der->f2k_derived->sym_root)
    3247                 :            :             {
    3248                 :       5348 :               st = gfc_find_symtree (der->f2k_derived->sym_root, name);
    3249                 :       5348 :               if (st)
    3250                 :            :                 break;
    3251                 :            :             }
    3252                 :            :         }
    3253                 :       5215 :       *result = st;
    3254                 :       5215 :       return 0;
    3255                 :            :     }
    3256                 :            : 
    3257                 :    4626650 :   *result = NULL;
    3258                 :            : 
    3259                 :    4626650 :   return 0;
    3260                 :            : }
    3261                 :            : 
    3262                 :            : 
    3263                 :            : /* Same, but returns the symbol instead.  */
    3264                 :            : 
    3265                 :            : int
    3266                 :    1424220 : gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
    3267                 :            :                  gfc_symbol **result)
    3268                 :            : {
    3269                 :    1424220 :   gfc_symtree *st;
    3270                 :    1424220 :   int i;
    3271                 :            : 
    3272                 :    1424220 :   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
    3273                 :            : 
    3274                 :    1424220 :   if (st == NULL)
    3275                 :    1101740 :     *result = NULL;
    3276                 :            :   else
    3277                 :     322479 :     *result = st->n.sym;
    3278                 :            : 
    3279                 :    1424220 :   return i;
    3280                 :            : }
    3281                 :            : 
    3282                 :            : 
    3283                 :            : /* Tells whether there is only one set of changes in the stack.  */
    3284                 :            : 
    3285                 :            : static bool
    3286                 :   24388200 : single_undo_checkpoint_p (void)
    3287                 :            : {
    3288                 :   24388200 :   if (latest_undo_chgset == &default_undo_chgset_var)
    3289                 :            :     {
    3290                 :   24388200 :       gcc_assert (latest_undo_chgset->previous == NULL);
    3291                 :            :       return true;
    3292                 :            :     }
    3293                 :            :   else
    3294                 :            :     {
    3295                 :          0 :       gcc_assert (latest_undo_chgset->previous != NULL);
    3296                 :            :       return false;
    3297                 :            :     }
    3298                 :            : }
    3299                 :            : 
    3300                 :            : /* Save symbol with the information necessary to back it out.  */
    3301                 :            : 
    3302                 :            : void
    3303                 :    3722590 : gfc_save_symbol_data (gfc_symbol *sym)
    3304                 :            : {
    3305                 :    3722590 :   gfc_symbol *s;
    3306                 :    3722590 :   unsigned i;
    3307                 :            : 
    3308                 :    3722590 :   if (!single_undo_checkpoint_p ())
    3309                 :            :     {
    3310                 :            :       /* If there is more than one change set, look for the symbol in the
    3311                 :            :          current one.  If it is found there, we can reuse it.  */
    3312                 :          0 :       FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
    3313                 :          0 :         if (s == sym)
    3314                 :            :           {
    3315                 :          0 :             gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
    3316                 :    3722590 :             return;
    3317                 :            :           }
    3318                 :            :     }
    3319                 :    3722590 :   else if (sym->gfc_new || sym->old_symbol != NULL)
    3320                 :            :     return;
    3321                 :            : 
    3322                 :    1790380 :   s = XCNEW (gfc_symbol);
    3323                 :    1790380 :   *s = *sym;
    3324                 :    1790380 :   sym->old_symbol = s;
    3325                 :    1790380 :   sym->gfc_new = 0;
    3326                 :            : 
    3327                 :    1790380 :   latest_undo_chgset->syms.safe_push (sym);
    3328                 :            : }
    3329                 :            : 
    3330                 :            : 
    3331                 :            : /* Given a name, find a symbol, or create it if it does not exist yet
    3332                 :            :    in the current namespace.  If the symbol is found we make sure that
    3333                 :            :    it's OK.
    3334                 :            : 
    3335                 :            :    The integer return code indicates
    3336                 :            :      0   All OK
    3337                 :            :      1   The symbol name was ambiguous
    3338                 :            :      2   The name meant to be established was already host associated.
    3339                 :            : 
    3340                 :            :    So if the return value is nonzero, then an error was issued.  */
    3341                 :            : 
    3342                 :            : int
    3343                 :    3840570 : gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
    3344                 :            :                   bool allow_subroutine)
    3345                 :            : {
    3346                 :    3840570 :   gfc_symtree *st;
    3347                 :    3840570 :   gfc_symbol *p;
    3348                 :            : 
    3349                 :            :   /* This doesn't usually happen during resolution.  */
    3350                 :    3840570 :   if (ns == NULL)
    3351                 :    1927720 :     ns = gfc_current_ns;
    3352                 :            : 
    3353                 :            :   /* Try to find the symbol in ns.  */
    3354                 :    3840570 :   st = gfc_find_symtree (ns->sym_root, name);
    3355                 :            : 
    3356                 :    3840570 :   if (st == NULL && ns->omp_udr_ns)
    3357                 :            :     {
    3358                 :        319 :       ns = ns->parent;
    3359                 :        319 :       st = gfc_find_symtree (ns->sym_root, name);
    3360                 :            :     }
    3361                 :            : 
    3362                 :    3840570 :   if (st == NULL)
    3363                 :            :     {
    3364                 :            :       /* If not there, create a new symbol.  */
    3365                 :    3304420 :       p = gfc_new_symbol (name, ns);
    3366                 :            : 
    3367                 :            :       /* Add to the list of tentative symbols.  */
    3368                 :    3304420 :       p->old_symbol = NULL;
    3369                 :    3304420 :       p->mark = 1;
    3370                 :    3304420 :       p->gfc_new = 1;
    3371                 :    3304420 :       latest_undo_chgset->syms.safe_push (p);
    3372                 :            : 
    3373                 :    3304420 :       st = gfc_new_symtree (&ns->sym_root, name);
    3374                 :    3304420 :       st->n.sym = p;
    3375                 :    3304420 :       p->refs++;
    3376                 :            : 
    3377                 :            :     }
    3378                 :            :   else
    3379                 :            :     {
    3380                 :            :       /* Make sure the existing symbol is OK.  Ambiguous
    3381                 :            :          generic interfaces are permitted, as long as the
    3382                 :            :          specific interfaces are different.  */
    3383                 :     536143 :       if (st->ambiguous && !st->n.sym->attr.generic)
    3384                 :            :         {
    3385                 :          4 :           ambiguous_symbol (name, st);
    3386                 :          4 :           return 1;
    3387                 :            :         }
    3388                 :            : 
    3389                 :     536139 :       p = st->n.sym;
    3390                 :     536139 :       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
    3391                 :       6227 :           && !(allow_subroutine && p->attr.subroutine)
    3392                 :       6224 :           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
    3393                 :       6194 :           && (ns->has_import_set || p->attr.imported)))
    3394                 :            :         {
    3395                 :            :           /* Symbol is from another namespace.  */
    3396                 :         31 :           gfc_error ("Symbol %qs at %C has already been host associated",
    3397                 :            :                      name);
    3398                 :         31 :           return 2;
    3399                 :            :         }
    3400                 :            : 
    3401                 :     536108 :       p->mark = 1;
    3402                 :            : 
    3403                 :            :       /* Copy in case this symbol is changed.  */
    3404                 :     536108 :       gfc_save_symbol_data (p);
    3405                 :            :     }
    3406                 :            : 
    3407                 :    3840530 :   *result = st;
    3408                 :    3840530 :   return 0;
    3409                 :            : }
    3410                 :            : 
    3411                 :            : 
    3412                 :            : int
    3413                 :     657794 : gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
    3414                 :            : {
    3415                 :     657794 :   gfc_symtree *st;
    3416                 :     657794 :   int i;
    3417                 :            : 
    3418                 :     657794 :   i = gfc_get_sym_tree (name, ns, &st, false);
    3419                 :     657794 :   if (i != 0)
    3420                 :            :     return i;
    3421                 :            : 
    3422                 :     657789 :   if (st)
    3423                 :     657789 :     *result = st->n.sym;
    3424                 :            :   else
    3425                 :          0 :     *result = NULL;
    3426                 :            :   return i;
    3427                 :            : }
    3428                 :            : 
    3429                 :            : 
    3430                 :            : /* Subroutine that searches for a symbol, creating it if it doesn't
    3431                 :            :    exist, but tries to host-associate the symbol if possible.  */
    3432                 :            : 
    3433                 :            : int
    3434                 :    4858520 : gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
    3435                 :            : {
    3436                 :    4858520 :   gfc_symtree *st;
    3437                 :    4858520 :   int i;
    3438                 :            : 
    3439                 :    4858520 :   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
    3440                 :            : 
    3441                 :    4858520 :   if (st != NULL)
    3442                 :            :     {
    3443                 :    3144640 :       gfc_save_symbol_data (st->n.sym);
    3444                 :    3144640 :       *result = st;
    3445                 :    3144640 :       return i;
    3446                 :            :     }
    3447                 :            : 
    3448                 :    1713880 :   i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
    3449                 :    1713880 :   if (i)
    3450                 :            :     return i;
    3451                 :            : 
    3452                 :    1713880 :   if (st != NULL)
    3453                 :            :     {
    3454                 :     130671 :       *result = st;
    3455                 :     130671 :       return 0;
    3456                 :            :     }
    3457                 :            : 
    3458                 :    1583210 :   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
    3459                 :            : }
    3460                 :            : 
    3461                 :            : 
    3462                 :            : int
    3463                 :      21309 : gfc_get_ha_symbol (const char *name, gfc_symbol **result)
    3464                 :            : {
    3465                 :      21309 :   int i;
    3466                 :      21309 :   gfc_symtree *st;
    3467                 :            : 
    3468                 :      21309 :   i = gfc_get_ha_sym_tree (name, &st);
    3469                 :            : 
    3470                 :      21309 :   if (st)
    3471                 :      21309 :     *result = st->n.sym;
    3472                 :            :   else
    3473                 :          0 :     *result = NULL;
    3474                 :            : 
    3475                 :      21309 :   return i;
    3476                 :            : }
    3477                 :            : 
    3478                 :            : 
    3479                 :            : /* Search for the symtree belonging to a gfc_common_head; we cannot use
    3480                 :            :    head->name as the common_root symtree's name might be mangled.  */
    3481                 :            : 
    3482                 :            : static gfc_symtree *
    3483                 :         17 : find_common_symtree (gfc_symtree *st, gfc_common_head *head)
    3484                 :            : {
    3485                 :            : 
    3486                 :         20 :   gfc_symtree *result;
    3487                 :            : 
    3488                 :         20 :   if (st == NULL)
    3489                 :            :     return NULL;
    3490                 :            : 
    3491                 :         14 :   if (st->n.common == head)
    3492                 :            :     return st;
    3493                 :            : 
    3494                 :          3 :   result = find_common_symtree (st->left, head);
    3495                 :          3 :   if (!result)
    3496                 :          3 :     result = find_common_symtree (st->right, head);
    3497                 :            : 
    3498                 :            :   return result;
    3499                 :            : }
    3500                 :            : 
    3501                 :            : 
    3502                 :            : /* Restore previous state of symbol.  Just copy simple stuff.  */
    3503                 :            : 
    3504                 :            : static void
    3505                 :     807776 : restore_old_symbol (gfc_symbol *p)
    3506                 :            : {
    3507                 :     807776 :   gfc_symbol *old;
    3508                 :            : 
    3509                 :     807776 :   p->mark = 0;
    3510                 :     807776 :   old = p->old_symbol;
    3511                 :            : 
    3512                 :     807776 :   p->ts.type = old->ts.type;
    3513                 :     807776 :   p->ts.kind = old->ts.kind;
    3514                 :            : 
    3515                 :     807776 :   p->attr = old->attr;
    3516                 :            : 
    3517                 :     807776 :   if (p->value != old->value)
    3518                 :            :     {
    3519                 :          1 :       gcc_checking_assert (old->value == NULL);
    3520                 :          1 :       gfc_free_expr (p->value);
    3521                 :          1 :       p->value = NULL;
    3522                 :            :     }
    3523                 :            : 
    3524                 :     807776 :   if (p->as != old->as)
    3525                 :            :     {
    3526                 :          3 :       if (p->as)
    3527                 :          3 :         gfc_free_array_spec (p->as);
    3528                 :          3 :       p->as = old->as;
    3529                 :            :     }
    3530                 :            : 
    3531                 :     807776 :   p->generic = old->generic;
    3532                 :     807776 :   p->component_access = old->component_access;
    3533                 :            : 
    3534                 :     807776 :   if (p->namelist != NULL && old->namelist == NULL)
    3535                 :            :     {
    3536                 :          0 :       gfc_free_namelist (p->namelist);
    3537                 :          0 :       p->namelist = NULL;
    3538                 :            :     }
    3539                 :            :   else
    3540                 :            :     {
    3541                 :     807776 :       if (p->namelist_tail != old->namelist_tail)
    3542                 :            :         {
    3543                 :          1 :           gfc_free_namelist (old->namelist_tail->next);
    3544                 :          1 :           old->namelist_tail->next = NULL;
    3545                 :            :         }
    3546                 :            :     }
    3547                 :            : 
    3548                 :     807776 :   p->namelist_tail = old->namelist_tail;
    3549                 :            : 
    3550                 :     807776 :   if (p->formal != old->formal)
    3551                 :            :     {
    3552                 :         14 :       gfc_free_formal_arglist (p->formal);
    3553                 :         14 :       p->formal = old->formal;
    3554                 :            :     }
    3555                 :            : 
    3556                 :     807776 :   set_symbol_common_block (p, old->common_block);
    3557                 :     807776 :   p->common_head = old->common_head;
    3558                 :            : 
    3559                 :     807776 :   p->old_symbol = old->old_symbol;
    3560                 :     807776 :   free (old);
    3561                 :     807776 : }
    3562                 :            : 
    3563                 :            : 
    3564                 :            : /* Frees the internal data of a gfc_undo_change_set structure.  Doesn't free
    3565                 :            :    the structure itself.  */
    3566                 :            : 
    3567                 :            : static void
    3568                 :      64331 : free_undo_change_set_data (gfc_undo_change_set &cs)
    3569                 :            : {
    3570                 :      64331 :   cs.syms.release ();
    3571                 :      64331 :   cs.tbps.release ();
    3572                 :      64331 : }
    3573                 :            : 
    3574                 :            : 
    3575                 :            : /* Given a change set pointer, free its target's contents and update it with
    3576                 :            :    the address of the previous change set.  Note that only the contents are
    3577                 :            :    freed, not the target itself (the contents' container).  It is not a problem
    3578                 :            :    as the latter will be a local variable usually.  */
    3579                 :            : 
    3580                 :            : static void
    3581                 :          0 : pop_undo_change_set (gfc_undo_change_set *&cs)
    3582                 :            : {
    3583                 :          0 :   free_undo_change_set_data (*cs);
    3584                 :          0 :   cs = cs->previous;
    3585                 :          0 : }
    3586                 :            : 
    3587                 :            : 
    3588                 :            : static void free_old_symbol (gfc_symbol *sym);
    3589                 :            : 
    3590                 :            : 
    3591                 :            : /* Merges the current change set into the previous one.  The changes themselves
    3592                 :            :    are left untouched; only one checkpoint is forgotten.  */
    3593                 :            : 
    3594                 :            : void
    3595                 :          0 : gfc_drop_last_undo_checkpoint (void)
    3596                 :            : {
    3597                 :          0 :   gfc_symbol *s, *t;
    3598                 :          0 :   unsigned i, j;
    3599                 :            : 
    3600                 :          0 :   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
    3601                 :            :     {
    3602                 :            :       /* No need to loop in this case.  */
    3603                 :          0 :       if (s->old_symbol == NULL)
    3604                 :          0 :         continue;
    3605                 :            : 
    3606                 :            :       /* Remove the duplicate symbols.  */
    3607                 :          0 :       FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
    3608                 :          0 :         if (t == s)
    3609                 :            :           {
    3610                 :          0 :             latest_undo_chgset->previous->syms.unordered_remove (j);
    3611                 :            : 
    3612                 :            :             /* S->OLD_SYMBOL is the backup symbol for S as it was at the
    3613                 :            :                last checkpoint.  We drop that checkpoint, so S->OLD_SYMBOL
    3614                 :            :                shall contain from now on the backup symbol for S as it was
    3615                 :            :                at the checkpoint before.  */
    3616                 :          0 :             if (s->old_symbol->gfc_new)
    3617                 :            :               {
    3618                 :          0 :                 gcc_assert (s->old_symbol->old_symbol == NULL);
    3619                 :          0 :                 s->gfc_new = s->old_symbol->gfc_new;
    3620                 :          0 :                 free_old_symbol (s);
    3621                 :            :               }
    3622                 :            :             else
    3623                 :          0 :               restore_old_symbol (s->old_symbol);
    3624                 :            :             break;
    3625                 :            :           }
    3626                 :            :     }
    3627                 :            : 
    3628                 :          0 :   latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
    3629                 :          0 :   latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
    3630                 :            : 
    3631                 :          0 :   pop_undo_change_set (latest_undo_chgset);
    3632                 :          0 : }
    3633                 :            : 
    3634                 :            : 
    3635                 :            : /* Undoes all the changes made to symbols since the previous checkpoint.
    3636                 :            :    This subroutine is made simpler due to the fact that attributes are
    3637                 :            :    never removed once added.  */
    3638                 :            : 
    3639                 :            : void
    3640                 :    8450720 : gfc_restore_last_undo_checkpoint (void)
    3641                 :            : {
    3642                 :    8450720 :   gfc_symbol *p;
    3643                 :    8450720 :   unsigned i;
    3644                 :            : 
    3645                 :   11960600 :   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
    3646                 :            :     {
    3647                 :            :       /* Symbol in a common block was new. Or was old and just put in common */
    3648                 :    3509900 :       if (p->common_block
    3649                 :       3768 :           && (p->gfc_new || !p->old_symbol->common_block))
    3650                 :            :         {
    3651                 :            :           /* If the symbol was added to any common block, it
    3652                 :            :              needs to be removed to stop the resolver looking
    3653                 :            :              for a (possibly) dead symbol.  */
    3654                 :         80 :           if (p->common_block->head == p && !p->common_next)
    3655                 :            :             {
    3656                 :         14 :               gfc_symtree st, *st0;
    3657                 :         14 :               st0 = find_common_symtree (p->ns->common_root,
    3658                 :            :                                          p->common_block);
    3659                 :         14 :               if (st0)
    3660                 :            :                 {
    3661                 :         11 :                   st.name = st0->name;
    3662                 :         11 :                   gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
    3663                 :         11 :                   free (st0);
    3664                 :            :                 }
    3665                 :            :             }
    3666                 :            : 
    3667                 :         80 :           if (p->common_block->head == p)
    3668                 :         79 :             p->common_block->head = p->common_next;
    3669                 :            :           else
    3670                 :            :             {
    3671                 :          1 :               gfc_symbol *cparent, *csym;
    3672                 :            : 
    3673                 :          1 :               cparent = p->common_block->head;
    3674                 :          1 :               csym = cparent->common_next;
    3675                 :            : 
    3676                 :          1 :               while (csym != p)
    3677                 :            :                 {
    3678                 :          0 :                   cparent = csym;
    3679                 :          0 :                   csym = csym->common_next;
    3680                 :            :                 }
    3681                 :            : 
    3682                 :          1 :               gcc_assert(cparent->common_next == p);
    3683                 :          1 :               cparent->common_next = csym->common_next;
    3684                 :            :             }
    3685                 :         80 :           p->common_next = NULL;
    3686                 :            :         }
    3687                 :    3509900 :       if (p->gfc_new)
    3688                 :            :         {
    3689                 :            :           /* The derived type is saved in the symtree with the first
    3690                 :            :              letter capitalized; the all lower-case version to the
    3691                 :            :              derived type contains its associated generic function.  */
    3692                 :    2702120 :           if (gfc_fl_struct (p->attr.flavor))
    3693                 :         28 :             gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
    3694                 :            :           else
    3695                 :    2702090 :             gfc_delete_symtree (&p->ns->sym_root, p->name);
    3696                 :            : 
    3697                 :    2702120 :           gfc_release_symbol (p);
    3698                 :            :         }
    3699                 :            :       else
    3700                 :     807776 :         restore_old_symbol (p);
    3701                 :            :     }
    3702                 :            : 
    3703                 :    8450720 :   latest_undo_chgset->syms.truncate (0);
    3704                 :    8450720 :   latest_undo_chgset->tbps.truncate (0);
    3705                 :            : 
    3706                 :    8450720 :   if (!single_undo_checkpoint_p ())
    3707                 :          0 :     pop_undo_change_set (latest_undo_chgset);
    3708                 :    8450720 : }
    3709                 :            : 
    3710                 :            : 
    3711                 :            : /* Makes sure that there is only one set of changes; in other words we haven't
    3712                 :            :    forgotten to pair a call to gfc_new_checkpoint with a call to either
    3713                 :            :    gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint.  */
    3714                 :            : 
    3715                 :            : static void
    3716                 :   12214800 : enforce_single_undo_checkpoint (void)
    3717                 :            : {
    3718                 :   12214800 :   gcc_checking_assert (single_undo_checkpoint_p ());
    3719                 :   12214800 : }
    3720                 :            : 
    3721                 :            : 
    3722                 :            : /* Undoes all the changes made to symbols in the current statement.  */
    3723                 :            : 
    3724                 :            : void
    3725                 :    8450720 : gfc_undo_symbols (void)
    3726                 :            : {
    3727                 :    8450720 :   enforce_single_undo_checkpoint ();
    3728                 :    8450720 :   gfc_restore_last_undo_checkpoint ();
    3729                 :    8450720 : }
    3730                 :            : 
    3731                 :            : 
    3732                 :            : /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
    3733                 :            :    components of old_symbol that might need deallocation are the "allocatables"
    3734                 :            :    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
    3735                 :            :    namelist_tail.  In case these differ between old_symbol and sym, it's just
    3736                 :            :    because sym->namelist has gotten a few more items.  */
    3737                 :            : 
    3738                 :            : static void
    3739                 :    1621130 : free_old_symbol (gfc_symbol *sym)
    3740                 :            : {
    3741                 :            : 
    3742                 :    1621130 :   if (sym->old_symbol == NULL)
    3743                 :            :     return;
    3744                 :            : 
    3745                 :     982603 :   if (sym->old_symbol->as != sym->as)
    3746                 :      19387 :     gfc_free_array_spec (sym->old_symbol->as);
    3747                 :            : 
    3748                 :     982603 :   if (sym->old_symbol->value != sym->value)
    3749                 :       2168 :     gfc_free_expr (sym->old_symbol->value);
    3750                 :            : 
    3751                 :     982603 :   if (sym->old_symbol->formal != sym->formal)
    3752                 :      12066 :     gfc_free_formal_arglist (sym->old_symbol->formal);
    3753                 :            : 
    3754                 :     982603 :   free (sym->old_symbol);
    3755                 :     982603 :   sym->old_symbol = NULL;
    3756                 :            : }
    3757                 :            : 
    3758                 :            : 
    3759                 :            : /* Makes the changes made in the current statement permanent-- gets
    3760                 :            :    rid of undo information.  */
    3761                 :            : 
    3762                 :            : void
    3763                 :     979334 : gfc_commit_symbols (void)
    3764                 :            : {
    3765                 :     979334 :   gfc_symbol *p;
    3766                 :     979334 :   gfc_typebound_proc *tbp;
    3767                 :     979334 :   unsigned i;
    3768                 :            : 
    3769                 :     979334 :   enforce_single_undo_checkpoint ();
    3770                 :            : 
    3771                 :    2247150 :   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
    3772                 :            :     {
    3773                 :    1267810 :       p->mark = 0;
    3774                 :    1267810 :       p->gfc_new = 0;
    3775                 :    1267810 :       free_old_symbol (p);
    3776                 :            :     }
    3777                 :     979334 :   latest_undo_chgset->syms.truncate (0);
    3778                 :            : 
    3779                 :    1010980 :   FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
    3780                 :      31650 :     tbp->error = 0;
    3781                 :     979334 :   latest_undo_chgset->tbps.truncate (0);
    3782                 :     979334 : }
    3783                 :            : 
    3784                 :            : 
    3785                 :            : /* Makes the changes made in one symbol permanent -- gets rid of undo
    3786                 :            :    information.  */
    3787                 :            : 
    3788                 :            : void
    3789                 :     353314 : gfc_commit_symbol (gfc_symbol *sym)
    3790                 :            : {
    3791                 :     353314 :   gfc_symbol *p;
    3792                 :     353314 :   unsigned i;
    3793                 :            : 
    3794                 :     353314 :   enforce_single_undo_checkpoint ();
    3795                 :            : 
    3796                 :     920556 :   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
    3797                 :     882494 :     if (p == sym)
    3798                 :            :       {
    3799                 :     315252 :         latest_undo_chgset->syms.unordered_remove (i);
    3800                 :            :         break;
    3801                 :            :       }
    3802                 :            : 
    3803                 :     353314 :   sym->mark = 0;
    3804                 :     353314 :   sym->gfc_new = 0;
    3805                 :            : 
    3806                 :     353314 :   free_old_symbol (sym);
    3807                 :     353314 : }
    3808                 :            : 
    3809                 :            : 
    3810                 :            : /* Recursively free trees containing type-bound procedures.  */
    3811                 :            : 
    3812                 :            : static void
    3813                 :     562074 : free_tb_tree (gfc_symtree *t)
    3814                 :            : {
    3815                 :     562074 :   if (t == NULL)
    3816                 :            :     return;
    3817                 :            : 
    3818                 :       5723 :   free_tb_tree (t->left);
    3819                 :       5723 :   free_tb_tree (t->right);
    3820                 :            : 
    3821                 :            :   /* TODO: Free type-bound procedure structs themselves; probably needs some
    3822                 :            :      sort of ref-counting mechanism.  */
    3823                 :            : 
    3824                 :       5723 :   free (t);
    3825                 :            : }
    3826                 :            : 
    3827                 :            : 
    3828                 :            : /* Recursive function that deletes an entire tree and all the common
    3829                 :            :    head structures it points to.  */
    3830                 :            : 
    3831                 :            : static void
    3832                 :     279038 : free_common_tree (gfc_symtree * common_tree)
    3833                 :            : {
    3834                 :     279038 :   if (common_tree == NULL)
    3835                 :            :     return;
    3836                 :            : 
    3837                 :       1862 :   free_common_tree (common_tree->left);
    3838                 :       1862 :   free_common_tree (common_tree->right);
    3839                 :            : 
    3840                 :       1862 :   free (common_tree);
    3841                 :            : }
    3842                 :            : 
    3843                 :            : 
    3844                 :            : /* Recursive function that deletes an entire tree and all the common
    3845                 :            :    head structures it points to.  */
    3846                 :            : 
    3847                 :            : static void
    3848                 :     276320 : free_omp_udr_tree (gfc_symtree * omp_udr_tree)
    3849                 :            : {
    3850                 :     276320 :   if (omp_udr_tree == NULL)
    3851                 :            :     return;
    3852                 :            : 
    3853                 :        503 :   free_omp_udr_tree (omp_udr_tree->left);
    3854                 :        503 :   free_omp_udr_tree (omp_udr_tree->right);
    3855                 :            : 
    3856                 :        503 :   gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
    3857                 :        503 :   free (omp_udr_tree);
    3858                 :            : }
    3859                 :            : 
    3860                 :            : 
    3861                 :            : /* Recursive function that deletes an entire tree and all the user
    3862                 :            :    operator nodes that it contains.  */
    3863                 :            : 
    3864                 :            : static void
    3865                 :     275854 : free_uop_tree (gfc_symtree *uop_tree)
    3866                 :            : {
    3867                 :     275854 :   if (uop_tree == NULL)
    3868                 :            :     return;
    3869                 :            : 
    3870                 :        270 :   free_uop_tree (uop_tree->left);
    3871                 :        270 :   free_uop_tree (uop_tree->right);
    3872                 :            : 
    3873                 :        270 :   gfc_free_interface (uop_tree->n.uop->op);
    3874                 :        270 :   free (uop_tree->n.uop);
    3875                 :        270 :   free (uop_tree);
    3876                 :            : }
    3877                 :            : 
    3878                 :            : 
    3879                 :            : /* Recursive function that deletes an entire tree and all the symbols
    3880                 :            :    that it contains.  */
    3881                 :            : 
    3882                 :            : static void
    3883                 :    2006910 : free_sym_tree (gfc_symtree *sym_tree)
    3884                 :            : {
    3885                 :    2006910 :   if (sym_tree == NULL)
    3886                 :            :     return;
    3887                 :            : 
    3888                 :     865800 :   free_sym_tree (sym_tree->left);
    3889                 :     865800 :   free_sym_tree (sym_tree->right);
    3890                 :            : 
    3891                 :     865800 :   gfc_release_symbol (sym_tree->n.sym);
    3892                 :     865800 :   free (sym_tree);
    3893                 :            : }
    3894                 :            : 
    3895                 :            : 
    3896                 :            : /* Free the gfc_equiv_info's.  */
    3897                 :            : 
    3898                 :            : static void
    3899                 :      14733 : gfc_free_equiv_infos (gfc_equiv_info *s)
    3900                 :            : {
    3901                 :      14733 :   if (s == NULL)
    3902                 :            :     return;
    3903                 :       8152 :   gfc_free_equiv_infos (s->next);
    3904                 :       8152 :   free (s);
    3905                 :            : }
    3906                 :            : 
    3907                 :            : 
    3908                 :            : /* Free the gfc_equiv_lists.  */
    3909                 :            : 
    3910                 :            : static void
    3911                 :     281895 : gfc_free_equiv_lists (gfc_equiv_list *l)
    3912                 :            : {
    3913                 :     281895 :   if (l == NULL)
    3914                 :            :     return;
    3915                 :       6581 :   gfc_free_equiv_lists (l->next);
    3916                 :       6581 :   gfc_free_equiv_infos (l->equiv);
    3917                 :       6581 :   free (l);
    3918                 :            : }
    3919                 :            : 
    3920                 :            : 
    3921                 :            : /* Free a finalizer procedure list.  */
    3922                 :            : 
    3923                 :            : void
    3924                 :        349 : gfc_free_finalizer (gfc_finalizer* el)
    3925                 :            : {
    3926                 :        349 :   if (el)
    3927                 :            :     {
    3928                 :        349 :       gfc_release_symbol (el->proc_sym);
    3929                 :        349 :       free (el);
    3930                 :            :     }
    3931                 :        349 : }
    3932                 :            : 
    3933                 :            : static void
    3934                 :     275314 : gfc_free_finalizer_list (gfc_finalizer* list)
    3935                 :            : {
    3936                 :     275650 :   while (list)
    3937                 :            :     {
    3938                 :        336 :       gfc_finalizer* current = list;
    3939                 :        336 :       list = list->next;
    3940                 :        336 :       gfc_free_finalizer (current);
    3941                 :            :     }
    3942                 :     275314 : }
    3943                 :            : 
    3944                 :            : 
    3945                 :            : /* Create a new gfc_charlen structure and add it to a namespace.
    3946                 :            :    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
    3947                 :            : 
    3948                 :            : gfc_charlen*
    3949                 :     176123 : gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
    3950                 :            : {
    3951                 :     176123 :   gfc_charlen *cl;
    3952                 :            : 
    3953                 :     176123 :   cl = gfc_get_charlen ();
    3954                 :            : 
    3955                 :            :   /* Copy old_cl.  */
    3956                 :     176123 :   if (old_cl)
    3957                 :            :     {
    3958                 :       5477 :       cl->length = gfc_copy_expr (old_cl->length);
    3959                 :       5477 :       cl->length_from_typespec = old_cl->length_from_typespec;
    3960                 :       5477 :       cl->backend_decl = old_cl->backend_decl;
    3961                 :       5477 :       cl->passed_length = old_cl->passed_length;
    3962                 :       5477 :       cl->resolved = old_cl->resolved;
    3963                 :            :     }
    3964                 :            : 
    3965                 :            :   /* Put into namespace.  */
    3966                 :     176123 :   cl->next = ns->cl_list;
    3967                 :     176123 :   ns->cl_list = cl;
    3968                 :            : 
    3969                 :     176123 :   return cl;
    3970                 :            : }
    3971                 :            : 
    3972                 :            : 
    3973                 :            : /* Free the charlen list from cl to end (end is not freed).
    3974                 :            :    Free the whole list if end is NULL.  */
    3975                 :            : 
    3976                 :            : void
    3977                 :     275314 : gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
    3978                 :            : {
    3979                 :     448127 :   gfc_charlen *cl2;
    3980                 :            : 
    3981                 :     448127 :   for (; cl != end; cl = cl2)
    3982                 :            :     {
    3983                 :     172813 :       gcc_assert (cl);
    3984                 :            : 
    3985                 :     172813 :       cl2 = cl->next;
    3986                 :     172813 :       gfc_free_expr (cl->length);
    3987                 :     172813 :       free (cl);
    3988                 :            :     }
    3989                 :     275314 : }
    3990                 :            : 
    3991                 :            : 
    3992                 :            : /* Free entry list structs.  */
    3993                 :            : 
    3994                 :            : static void
    3995                 :          0 : free_entry_list (gfc_entry_list *el)
    3996                 :            : {
    3997                 :     276489 :   gfc_entry_list *next;
    3998                 :            : 
    3999                 :     276489 :   if (el == NULL)
    4000                 :          0 :     return;
    4001                 :            : 
    4002                 :       1175 :   next = el->next;
    4003                 :       1175 :   free (el);
    4004                 :       1175 :   free_entry_list (next);
    4005                 :            : }
    4006                 :            : 
    4007                 :            : 
    4008                 :            : /* Free a namespace structure and everything below it.  Interface
    4009                 :            :    lists associated with intrinsic operators are not freed.  These are
    4010                 :            :    taken care of when a specific name is freed.  */
    4011                 :            : 
    4012                 :            : void
    4013                 :    7269970 : gfc_free_namespace (gfc_namespace *ns)
    4014                 :            : {
    4015                 :    7269970 :   gfc_namespace *p, *q;
    4016                 :    7269970 :   int i;
    4017                 :            : 
    4018                 :    7269970 :   if (ns == NULL)
    4019                 :            :     return;
    4020                 :            : 
    4021                 :     292196 :   ns->refs--;
    4022                 :     292196 :   if (ns->refs > 0)
    4023                 :            :     return;
    4024                 :            : 
    4025                 :     275314 :   gcc_assert (ns->refs == 0);
    4026                 :            : 
    4027                 :     275314 :   gfc_free_statements (ns->code);
    4028                 :            : 
    4029                 :     275314 :   free_sym_tree (ns->sym_root);
    4030                 :     275314 :   free_uop_tree (ns->uop_root);
    4031                 :     275314 :   free_common_tree (ns->common_root);
    4032                 :     275314 :   free_omp_udr_tree (ns->omp_udr_root);
    4033                 :     275314 :   free_tb_tree (ns->tb_sym_root);
    4034                 :     275314 :   free_tb_tree (ns->tb_uop_root);
    4035                 :     275314 :   gfc_free_finalizer_list (ns->finalizers);
    4036                 :     275314 :   gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
    4037                 :     275314 :   gfc_free_charlen (ns->cl_list, NULL);
    4038                 :     275314 :   free_st_labels (ns->st_labels);
    4039                 :            : 
    4040                 :     275314 :   free_entry_list (ns->entries);
    4041                 :     275314 :   gfc_free_equiv (ns->equiv);
    4042                 :     275314 :   gfc_free_equiv_lists (ns->equiv_lists);
    4043                 :     275314 :   gfc_free_use_stmts (ns->use_stmts);
    4044                 :            : 
    4045                 :    7984110 :   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    4046                 :    7708790 :     gfc_free_interface (ns->op[i]);
    4047                 :            : 
    4048                 :     275314 :   gfc_free_data (ns->data);
    4049                 :     275314 :   p = ns->contained;
    4050                 :     275314 :   free (ns);
    4051                 :            : 
    4052                 :            :   /* Recursively free any contained namespaces.  */
    4053                 :     304893 :   while (p != NULL)
    4054                 :            :     {
    4055                 :      29579 :       q = p;
    4056                 :      29579 :       p = p->sibling;
    4057                 :      29579 :       gfc_free_namespace (q);
    4058                 :            :     }
    4059                 :            : }
    4060                 :            : 
    4061                 :            : 
    4062                 :            : void
    4063                 :      64216 : gfc_symbol_init_2 (void)
    4064                 :            : {
    4065                 :            : 
    4066                 :      64216 :   gfc_current_ns = gfc_get_namespace (NULL, 0);
    4067                 :      64216 : }
    4068                 :            : 
    4069                 :            : 
    4070                 :            : void
    4071                 :      64331 : gfc_symbol_done_2 (void)
    4072                 :            : {
    4073                 :      64331 :   if (gfc_current_ns != NULL)
    4074                 :            :     {
    4075                 :            :       /* free everything from the root.  */
    4076                 :      64340 :       while (gfc_current_ns->parent != NULL)
    4077                 :          9 :         gfc_current_ns = gfc_current_ns->parent;
    4078                 :      64331 :       gfc_free_namespace (gfc_current_ns);
    4079                 :      64331 :       gfc_current_ns = NULL;
    4080                 :            :     }
    4081                 :      64331 :   gfc_derived_types = NULL;
    4082                 :            : 
    4083                 :      64331 :   enforce_single_undo_checkpoint ();
    4084                 :      64331 :   free_undo_change_set_data (*latest_undo_chgset);
    4085                 :      64331 : }
    4086                 :            : 
    4087                 :            : 
    4088                 :            : /* Count how many nodes a symtree has.  */
    4089                 :            : 
    4090                 :            : static unsigned
    4091                 :    9710150 : count_st_nodes (const gfc_symtree *st)
    4092                 :            : {
    4093                 :   21142400 :   unsigned nodes;
    4094                 :   16464200 :   if (!st)
    4095                 :    9710150 :     return 0;
    4096                 :            : 
    4097                 :    9710150 :   nodes = count_st_nodes (st->left);
    4098                 :    9710150 :   nodes++;
    4099                 :    9710150 :   nodes += count_st_nodes (st->right);
    4100                 :            : 
    4101                 :    2956140 :   return nodes;
    4102                 :            : }
    4103                 :            : 
    4104                 :            : 
    4105                 :            : /* Convert symtree tree into symtree vector.  */
    4106                 :            : 
    4107                 :            : static unsigned
    4108                 :   11432300 : fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
    4109                 :            : {
    4110                 :   21142400 :   if (!st)
    4111                 :   11432300 :     return node_cntr;
    4112                 :            : 
    4113                 :    9710150 :   node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
    4114                 :    9710150 :   st_vec[node_cntr++] = st;
    4115                 :    9710150 :   node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
    4116                 :            : 
    4117                 :    9710150 :   return node_cntr;
    4118                 :            : }
    4119                 :            : 
    4120                 :            : 
    4121                 :            : /* Traverse namespace.  As the functions might modify the symtree, we store the
    4122                 :            :    symtree as a vector and operate on this vector.  Note: We assume that
    4123                 :            :    sym_func or st_func never deletes nodes from the symtree - only adding is
    4124                 :            :    allowed. Additionally, newly added nodes are not traversed.  */
    4125                 :            : 
    4126                 :            : static void
    4127                 :    1722120 : do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
    4128                 :            :                      void (*sym_func) (gfc_symbol *))
    4129                 :            : {
    4130                 :    1722120 :   gfc_symtree **st_vec;
    4131                 :    1722120 :   unsigned nodes, i, node_cntr;
    4132                 :            : 
    4133                 :    1722120 :   gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
    4134                 :    4678270 :   nodes = count_st_nodes (st);
    4135                 :    1722120 :   st_vec = XALLOCAVEC (gfc_symtree *, nodes);
    4136                 :    1722120 :   node_cntr = 0;
    4137                 :    1722120 :   fill_st_vector (st, st_vec, node_cntr);
    4138                 :            : 
    4139                 :    1722120 :   if (sym_func)
    4140                 :            :     {
    4141                 :            :       /* Clear marks.  */
    4142                 :   11230600 :       for (i = 0; i < nodes; i++)
    4143                 :    9603430 :         st_vec[i]->n.sym->mark = 0;
    4144                 :   11230600 :       for (i = 0; i < nodes; i++)
    4145                 :    9603430 :         if (!st_vec[i]->n.sym->mark)
    4146                 :            :           {
    4147                 :    9522410 :             (*sym_func) (st_vec[i]->n.sym);
    4148                 :    9522410 :             st_vec[i]->n.sym->mark = 1;
    4149                 :            :           }
    4150                 :            :      }
    4151                 :            :    else
    4152                 :     201668 :       for (i = 0; i < nodes; i++)
    4153                 :     106715 :         (*st_func) (st_vec[i]);
    4154                 :    1722120 : }
    4155                 :            : 
    4156                 :            : 
    4157                 :            : /* Recursively traverse the symtree nodes.  */
    4158                 :            : 
    4159                 :            : void
    4160                 :      94953 : gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
    4161                 :            : {
    4162                 :      94953 :   do_traverse_symtree (st, st_func, NULL);
    4163                 :      94953 : }
    4164                 :            : 
    4165                 :            : 
    4166                 :            : /* Call a given function for all symbols in the namespace.  We take
    4167                 :            :    care that each gfc_symbol node is called exactly once.  */
    4168                 :            : 
    4169                 :            : void
    4170                 :    1627170 : gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
    4171                 :            : {
    4172                 :    1627170 :   do_traverse_symtree (ns->sym_root, NULL, sym_func);
    4173                 :    1627170 : }
    4174                 :            : 
    4175                 :            : 
    4176                 :            : /* Return TRUE when name is the name of an intrinsic type.  */
    4177                 :            : 
    4178                 :            : bool
    4179                 :      10233 : gfc_is_intrinsic_typename (const char *name)
    4180                 :            : {
    4181                 :      10233 :   if (strcmp (name, "integer") == 0
    4182                 :      10230 :       || strcmp (name, "real") == 0
    4183                 :      10227 :       || strcmp (name, "character") == 0
    4184                 :      10225 :       || strcmp (name, "logical") == 0
    4185                 :      10223 :       || strcmp (name, "complex") == 0
    4186                 :      10219 :       || strcmp (name, "doubleprecision") == 0
    4187                 :      10216 :       || strcmp (name, "doublecomplex") == 0)
    4188                 :            :     return true;
    4189                 :            :   else
    4190                 :      10213 :     return false;
    4191                 :            : }
    4192                 :            : 
    4193                 :            : 
    4194                 :            : /* Return TRUE if the symbol is an automatic variable.  */
    4195                 :            : 
    4196                 :            : static bool
    4197                 :        845 : gfc_is_var_automatic (gfc_symbol *sym)
    4198                 :            : {
    4199                 :            :   /* Pointer and allocatable variables are never automatic.  */
    4200                 :        845 :   if (sym->attr.pointer || sym->attr.allocatable)
    4201                 :            :     return false;
    4202                 :            :   /* Check for arrays with non-constant size.  */
    4203                 :         74 :   if (sym->attr.dimension && sym->as
    4204                 :        858 :       && !gfc_is_compile_time_shape (sym->as))
    4205                 :            :     return true;
    4206                 :            :   /* Check for non-constant length character variables.  */
    4207                 :        770 :   if (sym->ts.type == BT_CHARACTER
    4208                 :         82 :       && sym->ts.u.cl
    4209                 :        852 :       && !gfc_is_constant_expr (sym->ts.u.cl->length))
    4210                 :            :     return true;
    4211                 :            :   /* Variables with explicit AUTOMATIC attribute.  */
    4212                 :        762 :   if (sym->attr.automatic)
    4213                 :         18 :       return true;
    4214                 :            : 
    4215                 :            :   return false;
    4216                 :            : }
    4217                 :            : 
    4218                 :            : /* Given a symbol, mark it as SAVEd if it is allowed.  */
    4219                 :            : 
    4220                 :            : static void
    4221                 :       2595 : save_symbol (gfc_symbol *sym)
    4222                 :            : {
    4223                 :            : 
    4224                 :       2595 :   if (sym->attr.use_assoc)
    4225                 :            :     return;
    4226                 :            : 
    4227                 :       2362 :   if (sym->attr.in_common
    4228                 :            :       || sym->attr.in_equivalence
    4229                 :            :       || sym->attr.dummy
    4230                 :       2362 :       || sym->attr.result
    4231                 :       1934 :       || sym->attr.flavor != FL_VARIABLE)
    4232                 :            :     return;
    4233                 :            :   /* Automatic objects are not saved.  */
    4234                 :        845 :   if (gfc_is_var_automatic (sym))
    4235                 :            :     return;
    4236                 :        805 :   gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
    4237                 :            : }
    4238                 :            : 
    4239                 :            : 
    4240                 :            : /* Mark those symbols which can be SAVEd as such.  */
    4241                 :            : 
    4242                 :            : void
    4243                 :        335 : gfc_save_all (gfc_namespace *ns)
    4244                 :            : {
    4245                 :        335 :   gfc_traverse_ns (ns, save_symbol);
    4246                 :        335 : }
    4247                 :            : 
    4248                 :            : 
    4249                 :            : /* Make sure that no changes to symbols are pending.  */
    4250                 :            : 
    4251                 :            : void
    4252                 :    2367150 : gfc_enforce_clean_symbol_state(void)
    4253                 :            : {
    4254                 :    2367150 :   enforce_single_undo_checkpoint ();
    4255                 :    2367150 :   gcc_assert (latest_undo_chgset->syms.is_empty ());
    4256                 :    2367150 : }
    4257                 :            : 
    4258                 :            : 
    4259                 :            : /************** Global symbol handling ************/
    4260                 :            : 
    4261                 :            : 
    4262                 :            : /* Search a tree for the global symbol.  */
    4263                 :            : 
    4264                 :            : gfc_gsymbol *
    4265                 :     163001 : gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
    4266                 :            : {
    4267                 :     163001 :   int c;
    4268                 :            : 
    4269                 :     163001 :   if (symbol == NULL)
    4270                 :            :     return NULL;
    4271                 :            : 
    4272                 :     396159 :   while (symbol)
    4273                 :            :     {
    4274                 :     334724 :       c = strcmp (name, symbol->name);
    4275                 :     334724 :       if (!c)
    4276                 :      75633 :         return symbol;
    4277                 :            : 
    4278                 :     259091 :       symbol = (c < 0) ? symbol->left : symbol->right;
    4279                 :            :     }
    4280                 :            : 
    4281                 :            :   return NULL;
    4282                 :            : }
    4283                 :            : 
    4284                 :            : 
    4285                 :            : /* Case insensitive search a tree for the global symbol.  */
    4286                 :            : 
    4287                 :            : gfc_gsymbol *
    4288                 :       3416 : gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
    4289                 :            : {
    4290                 :       3416 :   int c;
    4291                 :            : 
    4292                 :       3416 :   if (symbol == NULL)
    4293                 :            :     return NULL;
    4294                 :            : 
    4295                 :      10579 :   while (symbol)
    4296                 :            :     {
    4297                 :       9278 :       c = strcasecmp (name, symbol->name);
    4298                 :       9278 :       if (!c)
    4299                 :       2060 :         return symbol;
    4300                 :            : 
    4301                 :       7218 :       symbol = (c < 0) ? symbol->left : symbol->right;
    4302                 :            :     }
    4303                 :            : 
    4304                 :            :   return NULL;
    4305                 :            : }
    4306                 :            : 
    4307                 :            : 
    4308                 :            : /* Compare two global symbols. Used for managing the BB tree.  */
    4309                 :            : 
    4310                 :            : static int
    4311                 :      63439 : gsym_compare (void *_s1, void *_s2)
    4312                 :            : {
    4313                 :      63439 :   gfc_gsymbol *s1, *s2;
    4314                 :            : 
    4315                 :      63439 :   s1 = (gfc_gsymbol *) _s1;
    4316                 :      63439 :   s2 = (gfc_gsymbol *) _s2;
    4317                 :      63439 :   return strcmp (s1->name, s2->name);
    4318                 :            : }
    4319                 :            : 
    4320                 :            : 
    4321                 :            : /* Get a global symbol, creating it if it doesn't exist.  */
    4322                 :            : 
    4323                 :            : gfc_gsymbol *
    4324                 :      70205 : gfc_get_gsymbol (const char *name, bool bind_c)
    4325                 :            : {
    4326                 :      70205 :   gfc_gsymbol *s;
    4327                 :            : 
    4328                 :      70205 :   s = gfc_find_gsymbol (gfc_gsym_root, name);
    4329                 :      70205 :   if (s != NULL)
    4330                 :            :     return s;
    4331                 :            : 
    4332                 :      48782 :   s = XCNEW (gfc_gsymbol);
    4333                 :      48782 :   s->type = GSYM_UNKNOWN;
    4334                 :      48782 :   s->name = gfc_get_string ("%s", name);
    4335                 :      48782 :   s->bind_c = bind_c;
    4336                 :            : 
    4337                 :      48782 :   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
    4338                 :            : 
    4339                 :      48782 :   return s;
    4340                 :            : }
    4341                 :            : 
    4342                 :            : void
    4343                 :          0 : gfc_traverse_gsymbol (gfc_gsymbol *gsym,
    4344                 :            :                       void (*do_something) (gfc_gsymbol *, void *),
    4345                 :            :                       void *data)
    4346                 :            : {
    4347                 :          0 :   if (gsym->left)
    4348                 :          0 :     gfc_traverse_gsymbol (gsym->left, do_something, data);
    4349                 :            : 
    4350                 :          0 :   (*do_something) (gsym, data);
    4351                 :            : 
    4352                 :          0 :   if (gsym->right)
    4353                 :            :     gfc_traverse_gsymbol (gsym->right, do_something, data);
    4354                 :          0 : }
    4355                 :            : 
    4356                 :            : static gfc_symbol *
    4357                 :         34 : get_iso_c_binding_dt (int sym_id)
    4358                 :            : {
    4359                 :         34 :   gfc_symbol *dt_list = gfc_derived_types;
    4360                 :            : 
    4361                 :            :   /* Loop through the derived types in the name list, searching for
    4362                 :            :      the desired symbol from iso_c_binding.  Search the parent namespaces
    4363                 :            :      if necessary and requested to (parent_flag).  */
    4364                 :          0 :   if (dt_list)
    4365                 :            :     {
    4366                 :         13 :       while (dt_list->dt_next != gfc_derived_types)
    4367                 :            :         {
    4368                 :          0 :           if (dt_list->from_intmod != INTMOD_NONE
    4369                 :          0 :               && dt_list->intmod_sym_id == sym_id)
    4370                 :          0 :             return dt_list;
    4371                 :            :         
    4372                 :            :           dt_list = dt_list->dt_next;
    4373                 :            :         }
    4374                 :            :     }
    4375                 :            : 
    4376                 :            :   return NULL;
    4377                 :            : }
    4378                 :            : 
    4379                 :            : 
    4380                 :            : /* Verifies that the given derived type symbol, derived_sym, is interoperable
    4381                 :            :    with C.  This is necessary for any derived type that is BIND(C) and for
    4382                 :            :    derived types that are parameters to functions that are BIND(C).  All
    4383                 :            :    fields of the derived type are required to be interoperable, and are tested
    4384                 :            :    for such.  If an error occurs, the errors are reported here, allowing for
    4385                 :            :    multiple errors to be handled for a single derived type.  */
    4386                 :            : 
    4387                 :            : bool
    4388                 :       2995 : verify_bind_c_derived_type (gfc_symbol *derived_sym)
    4389                 :            : {
    4390                 :       2995 :   gfc_component *curr_comp = NULL;
    4391                 :       2995 :   bool is_c_interop = false;
    4392                 :       2995 :   bool retval = true;
    4393                 :            : 
    4394                 :       2995 :   if (derived_sym == NULL)
    4395                 :          0 :     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
    4396                 :            :                         "unexpectedly NULL");
    4397                 :            : 
    4398                 :            :   /* If we've already looked at this derived symbol, do not look at it again
    4399                 :            :      so we don't repeat warnings/errors.  */
    4400                 :       2995 :   if (derived_sym->ts.is_c_interop)
    4401                 :            :     return true;
    4402                 :            : 
    4403                 :            :   /* The derived type must have the BIND attribute to be interoperable
    4404                 :            :      J3/04-007, Section 15.2.3.  */
    4405                 :        179 :   if (derived_sym->attr.is_bind_c != 1)
    4406                 :            :     {
    4407                 :          2 :       derived_sym->ts.is_c_interop = 0;
    4408                 :          2 :       gfc_error_now ("Derived type %qs declared at %L must have the BIND "
    4409                 :            :                      "attribute to be C interoperable", derived_sym->name,
    4410                 :            :                      &(derived_sym->declared_at));
    4411                 :          2 :       retval = false;
    4412                 :            :     }
    4413                 :            : 
    4414                 :        179 :   curr_comp = derived_sym->components;
    4415                 :            : 
    4416                 :            :   /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
    4417                 :            :      empty struct.  Section 15.2 in Fortran 2003 states:  "The following
    4418                 :            :      subclauses define the conditions under which a Fortran entity is
    4419                 :            :      interoperable.  If a Fortran entity is interoperable, an equivalent
    4420                 :            :      entity may be defined by means of C and the Fortran entity is said
    4421                 :            :      to be interoperable with the C entity.  There does not have to be such
    4422                 :            :      an interoperating C entity."
    4423                 :            :   */
    4424                 :        179 :   if (curr_comp == NULL)
    4425                 :            :     {
    4426                 :          1 :       gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
    4427                 :            :                    "and may be inaccessible by the C companion processor",
    4428                 :            :                    derived_sym->name, &(derived_sym->declared_at));
    4429                 :          1 :       derived_sym->ts.is_c_interop = 1;
    4430                 :          1 :       derived_sym->attr.is_bind_c = 1;
    4431                 :          1 :       return true;
    4432                 :            :     }
    4433                 :            : 
    4434                 :            : 
    4435                 :            :   /* Initialize the derived type as being C interoperable.
    4436                 :            :      If we find an error in the components, this will be set false.  */
    4437                 :        178 :   derived_sym->ts.is_c_interop = 1;
    4438                 :            : 
    4439                 :            :   /* Loop through the list of components to verify that the kind of
    4440                 :            :      each is a C interoperable type.  */
    4441                 :        403 :   do
    4442                 :            :     {
    4443                 :            :       /* The components cannot be pointers (fortran sense).
    4444                 :            :          J3/04-007, Section 15.2.3, C1505.      */
    4445                 :        403 :       if (curr_comp->attr.pointer != 0)
    4446                 :            :         {
    4447                 :          3 :           gfc_error ("Component %qs at %L cannot have the "
    4448                 :            :                      "POINTER attribute because it is a member "
    4449                 :            :                      "of the BIND(C) derived type %qs at %L",
    4450                 :            :                      curr_comp->name, &(curr_comp->loc),
    4451                 :            :                      derived_sym->name, &(derived_sym->declared_at));
    4452                 :          3 :           retval = false;
    4453                 :            :         }
    4454                 :            : 
    4455                 :        403 :       if (curr_comp->attr.proc_pointer != 0)
    4456                 :            :         {
    4457                 :          1 :           gfc_error ("Procedure pointer component %qs at %L cannot be a member"
    4458                 :            :                      " of the BIND(C) derived type %qs at %L", curr_comp->name,
    4459                 :            :                      &curr_comp->loc, derived_sym->name,
    4460                 :            :                      &derived_sym->declared_at);
    4461                 :          1 :           retval = false;
    4462                 :            :         }
    4463                 :            : 
    4464                 :            :       /* The components cannot be allocatable.
    4465                 :            :          J3/04-007, Section 15.2.3, C1505.      */
    4466                 :        403 :       if (curr_comp->attr.allocatable != 0)
    4467                 :            :         {
    4468                 :          3 :           gfc_error ("Component %qs at %L cannot have the "
    4469                 :            :                      "ALLOCATABLE attribute because it is a member "
    4470                 :            :                      "of the BIND(C) derived type %qs at %L",
    4471                 :            :                      curr_comp->name, &(curr_comp->loc),
    4472                 :            :                      derived_sym->name, &(derived_sym->declared_at));
    4473                 :          3 :           retval = false;
    4474                 :            :         }
    4475                 :            : 
    4476                 :            :       /* BIND(C) derived types must have interoperable components.  */
    4477                 :        403 :       if (curr_comp->ts.type == BT_DERIVED
    4478                 :         71 :           && curr_comp->ts.u.derived->ts.is_iso_c != 1
    4479                 :         17 :           && curr_comp->ts.u.derived != derived_sym)
    4480                 :            :         {
    4481                 :            :           /* This should be allowed; the draft says a derived-type cannot
    4482                 :            :              have type parameters if it is has the BIND attribute.  Type
    4483                 :            :              parameters seem to be for making parameterized derived types.
    4484                 :            :              There's no need to verify the type if it is c_ptr/c_funptr.  */
    4485                 :         16 :           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
    4486                 :            :         }
    4487                 :            :       else
    4488                 :            :         {
    4489                 :            :           /* Grab the typespec for the given component and test the kind.  */
    4490                 :        387 :           is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
    4491                 :            : 
    4492                 :        387 :           if (!is_c_interop)
    4493                 :            :             {
    4494                 :            :               /* Report warning and continue since not fatal.  The
    4495                 :            :                  draft does specify a constraint that requires all fields
    4496                 :            :                  to interoperate, but if the user says real(4), etc., it
    4497                 :            :                  may interoperate with *something* in C, but the compiler
    4498                 :            :                  most likely won't know exactly what.  Further, it may not
    4499                 :            :                  interoperate with the same data type(s) in C if the user
    4500                 :            :                  recompiles with different flags (e.g., -m32 and -m64 on
    4501                 :            :                  x86_64 and using integer(4) to claim interop with a
    4502                 :            :                  C_LONG).  */
    4503                 :          6 :               if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type)
    4504                 :            :                 /* If the derived type is bind(c), all fields must be
    4505                 :            :                    interop.  */
    4506                 :          1 :                 gfc_warning (OPT_Wc_binding_type,
    4507                 :            :                              "Component %qs in derived type %qs at %L "
    4508                 :            :                              "may not be C interoperable, even though "
    4509                 :            :                              "derived type %qs is BIND(C)",
    4510                 :            :                              curr_comp->name, derived_sym->name,
    4511                 :            :                              &(curr_comp->loc), derived_sym->name);
    4512                 :          5 :               else if (warn_c_binding_type)
    4513                 :            :                 /* If derived type is param to bind(c) routine, or to one
    4514                 :            :                    of the iso_c_binding procs, it must be interoperable, so
    4515                 :            :                    all fields must interop too.  */
    4516                 :          0 :                 gfc_warning (OPT_Wc_binding_type,
    4517                 :            :                              "Component %qs in derived type %qs at %L "
    4518                 :            :                              "may not be C interoperable",
    4519                 :            :                              curr_comp->name, derived_sym->name,
    4520                 :            :                              &(curr_comp->loc));
    4521                 :            :             }
    4522                 :            :         }
    4523                 :            : 
    4524                 :        403 :       curr_comp = curr_comp->next;
    4525                 :        403 :     } while (curr_comp != NULL);
    4526                 :            : 
    4527                 :        178 :   if (derived_sym->attr.sequence != 0)
    4528                 :            :     {
    4529                 :          0 :       gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
    4530                 :            :                  "attribute because it is BIND(C)", derived_sym->name,
    4531                 :            :                  &(derived_sym->declared_at));
    4532                 :          0 :       retval = false;
    4533                 :            :     }
    4534                 :            : 
    4535                 :            :   /* Mark the derived type as not being C interoperable if we found an
    4536                 :            :      error.  If there were only warnings, proceed with the assumption
    4537                 :            :      it's interoperable.  */
    4538                 :        178 :   if (!retval)
    4539                 :          8 :     derived_sym->ts.is_c_interop = 0;
    4540                 :            : 
    4541                 :            :   return retval;
    4542                 :            : }
    4543                 :            : 
    4544                 :            : 
    4545                 :            : /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
    4546                 :            : 
    4547                 :            : static bool
    4548                 :       2139 : gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
    4549                 :            : {
    4550                 :       2139 :   gfc_constructor *c;
    4551                 :            : 
    4552                 :       2139 :   gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
    4553                 :       2139 :   dt_symtree->n.sym->attr.referenced = 1;
    4554                 :            : 
    4555                 :       2139 :   tmp_sym->attr.is_c_interop = 1;
    4556                 :       2139 :   tmp_sym->attr.is_bind_c = 1;
    4557                 :       2139 :   tmp_sym->ts.is_c_interop = 1;
    4558                 :       2139 :   tmp_sym->ts.is_iso_c = 1;
    4559                 :       2139 :   tmp_sym->ts.type = BT_DERIVED;
    4560                 :       2139 :   tmp_sym->ts.f90_type = BT_VOID;
    4561                 :       2139 :   tmp_sym->attr.flavor = FL_PARAMETER;
    4562                 :       2139 :   tmp_sym->ts.u.derived = dt_symtree->n.sym;
    4563                 :            : 
    4564                 :            :   /* Set the c_address field of c_null_ptr and c_null_funptr to
    4565                 :            :      the value of NULL.  */
    4566                 :       2139 :   tmp_sym->value = gfc_get_expr ();
    4567                 :       2139 :   tmp_sym->value->expr_type = EXPR_STRUCTURE;
    4568                 :       2139 :   tmp_sym->value->ts.type = BT_DERIVED;
    4569                 :       2139 :   tmp_sym->value->ts.f90_type = BT_VOID;
    4570                 :       2139 :   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
    4571                 :       2139 :   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
    4572                 :       2139 :   c = gfc_constructor_first (tmp_sym->value->value.constructor);
    4573                 :       2139 :   c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    4574                 :       2139 :   c->expr->ts.is_iso_c = 1;
    4575                 :            : 
    4576                 :       2139 :   return true;
    4577                 :            : }
    4578                 :            : 
    4579                 :            : 
    4580                 :            : /* Add a formal argument, gfc_formal_arglist, to the
    4581                 :            :    end of the given list of arguments.  Set the reference to the
    4582                 :            :    provided symbol, param_sym, in the argument.  */
    4583                 :            : 
    4584                 :            : static void
    4585                 :      63945 : add_formal_arg (gfc_formal_arglist **head,
    4586                 :            :                 gfc_formal_arglist **tail,
    4587                 :            :                 gfc_formal_arglist *formal_arg,
    4588                 :            :                 gfc_symbol *param_sym)
    4589                 :            : {
    4590                 :            :   /* Put in list, either as first arg or at the tail (curr arg).  */
    4591                 :          0 :   if (*head == NULL)
    4592                 :          0 :     *head = *tail = formal_arg;
    4593                 :            :   else
    4594                 :            :     {
    4595                 :      38894 :       (*tail)->next = formal_arg;
    4596                 :      38894 :       (*tail) = formal_arg;
    4597                 :            :     }
    4598                 :            : 
    4599                 :      63945 :   (*tail)->sym = param_sym;
    4600                 :      63945 :   (*tail)->next = NULL;
    4601                 :            : 
    4602                 :      63945 :   return;
    4603                 :            : }
    4604                 :            : 
    4605                 :            : 
    4606                 :            : /* Add a procedure interface to the given symbol (i.e., store a
    4607                 :            :    reference to the list of formal arguments).  */
    4608                 :            : 
    4609                 :            : static void
    4610                 :      25884 : add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
    4611                 :            : {
    4612                 :            : 
    4613                 :      25884 :   sym->formal = formal;
    4614                 :      25884 :   sym->attr.if_source = source;
    4615                 :          0 : }
    4616                 :            : 
    4617                 :            : 
    4618                 :            : /* Copy the formal args from an existing symbol, src, into a new
    4619                 :            :    symbol, dest.  New formal args are created, and the description of
    4620                 :            :    each arg is set according to the existing ones.  This function is
    4621                 :            :    used when creating procedure declaration variables from a procedure
    4622                 :            :    declaration statement (see match_proc_decl()) to create the formal
    4623                 :            :    args based on the args of a given named interface.
    4624                 :            : 
    4625                 :            :    When an actual argument list is provided, skip the absent arguments.
    4626                 :            :    To be used together with gfc_se->ignore_optional.  */
    4627                 :            : 
    4628                 :            : void
    4629                 :      25884 : gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
    4630                 :            :                            gfc_actual_arglist *actual)
    4631                 :            : {
    4632                 :      25884 :   gfc_formal_arglist *head = NULL;
    4633                 :      25884 :   gfc_formal_arglist *tail = NULL;
    4634                 :      25884 :   gfc_formal_arglist *formal_arg = NULL;
    4635                 :      25884 :   gfc_intrinsic_arg *curr_arg = NULL;
    4636                 :      25884 :   gfc_formal_arglist *formal_prev = NULL;
    4637                 :      25884 :   gfc_actual_arglist *act_arg = actual;
    4638                 :            :   /* Save current namespace so we can change it for formal args.  */
    4639                 :      25884 :   gfc_namespace *parent_ns = gfc_current_ns;
    4640                 :            : 
    4641                 :            :   /* Create a new namespace, which will be the formal ns (namespace
    4642                 :            :      of the formal args).  */
    4643                 :      25884 :   gfc_current_ns = gfc_get_namespace (parent_ns, 0);
    4644                 :      25884 :   gfc_current_ns->proc_name = dest;
    4645                 :            : 
    4646                 :      98616 :   for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
    4647                 :            :     {
    4648                 :            :       /* Skip absent arguments.  */
    4649                 :      72732 :       if (actual)
    4650                 :            :         {
    4651                 :      32899 :           gcc_assert (act_arg != NULL);
    4652                 :      32899 :           if (act_arg->expr == NULL)
    4653                 :            :             {
    4654                 :       8787 :               act_arg = act_arg->next;
    4655                 :       8787 :               continue;
    4656                 :            :             }
    4657                 :      24112 :           act_arg = act_arg->next;
    4658                 :            :         }
    4659                 :      63945 :       formal_arg = gfc_get_formal_arglist ();
    4660                 :      63945 :       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
    4661                 :            : 
    4662                 :            :       /* May need to copy more info for the symbol.  */
    4663                 :      63945 :       formal_arg->sym->ts = curr_arg->ts;
    4664                 :      63945 :       formal_arg->sym->attr.optional = curr_arg->optional;
    4665                 :      63945 :       formal_arg->sym->attr.value = curr_arg->value;
    4666                 :      63945 :       formal_arg->sym->attr.intent = curr_arg->intent;
    4667                 :      63945 :       formal_arg->sym->attr.flavor = FL_VARIABLE;
    4668                 :      63945 :       formal_arg->sym->attr.dummy = 1;
    4669                 :            : 
    4670                 :      63945 :       if (formal_arg->sym->ts.type == BT_CHARACTER)
    4671                 :        867 :         formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    4672                 :            : 
    4673                 :            :       /* If this isn't the first arg, set up the next ptr.  For the
    4674                 :            :         last arg built, the formal_arg->next will never get set to
    4675                 :            :         anything other than NULL.  */
    4676                 :      63945 :       if (formal_prev != NULL)
    4677                 :      38894 :         formal_prev->next = formal_arg;
    4678                 :            :       else
    4679                 :      25051 :         formal_arg->next = NULL;
    4680                 :            : 
    4681                 :      63945 :       formal_prev = formal_arg;
    4682                 :            : 
    4683                 :            :       /* Add arg to list of formal args.  */
    4684                 :      63945 :       add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
    4685                 :            : 
    4686                 :            :       /* Validate changes.  */
    4687                 :      63945 :       gfc_commit_symbol (formal_arg->sym);
    4688                 :            :     }
    4689                 :            : 
    4690                 :            :   /* Add the interface to the symbol.  */
    4691                 :      25884 :   add_proc_interface (dest, IFSRC_DECL, head);
    4692                 :            : 
    4693                 :            :   /* Store the formal namespace information.  */
    4694                 :      25884 :   if (dest->formal != NULL)
    4695                 :            :     /* The current ns should be that for the dest proc.  */
    4696                 :      25051 :     dest->formal_ns = gfc_current_ns;
    4697                 :            :   /* Restore the current namespace to what it was on entry.  */
    4698                 :      25884 :   gfc_current_ns = parent_ns;
    4699                 :      25884 : }
    4700                 :            : 
    4701                 :            : 
    4702                 :            : static int
    4703                 :      51649 : std_for_isocbinding_symbol (int id)
    4704                 :            : {
    4705                 :          0 :   switch (id)
    4706                 :            :     {
    4707                 :            : #define NAMED_INTCST(a,b,c,d) \
    4708                 :            :       case a:\
    4709                 :            :         return d;
    4710                 :            : #include "iso-c-binding.def"
    4711                 :            : #undef NAMED_INTCST
    4712                 :            : 
    4713                 :            : #define NAMED_FUNCTION(a,b,c,d) \
    4714                 :            :       case a:\
    4715                 :            :         return d;
    4716                 :            : #define NAMED_SUBROUTINE(a,b,c,d) \
    4717                 :            :       case a:\
    4718                 :            :         return d;
    4719                 :            : #include "iso-c-binding.def"
    4720                 :            : #undef NAMED_FUNCTION
    4721                 :            : #undef NAMED_SUBROUTINE
    4722                 :            : 
    4723                 :            :        default:
    4724                 :            :          return GFC_STD_F2003;
    4725                 :            :     }
    4726                 :            : }
    4727                 :            : 
    4728                 :            : /* Generate the given set of C interoperable kind objects, or all
    4729                 :            :    interoperable kinds.  This function will only be given kind objects
    4730                 :            :    for valid iso_c_binding defined types because this is verified when
    4731                 :            :    the 'use' statement is parsed.  If the user gives an 'only' clause,
    4732                 :            :    the specific kinds are looked up; if they don't exist, an error is
    4733                 :            :    reported.  If the user does not give an 'only' clause, all
    4734                 :            :    iso_c_binding symbols are generated.  If a list of specific kinds
    4735                 :            :    is given, it must have a NULL in the first empty spot to mark the
    4736                 :            :    end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
    4737                 :            :    point to the symtree for c_(fun)ptr.  */
    4738                 :            : 
    4739                 :            : gfc_symtree *
    4740                 :      51649 : generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
    4741                 :            :                              const char *local_name, gfc_symtree *dt_symtree,
    4742                 :            :                              bool hidden)
    4743                 :            : {
    4744                 :       3596 :   const char *const name = (local_name && local_name[0])
    4745                 :      51649 :                            ? local_name : c_interop_kinds_table[s].name;
    4746                 :      51649 :   gfc_symtree *tmp_symtree;
    4747                 :      51649 :   gfc_symbol *tmp_sym = NULL;
    4748                 :      51649 :   int index;
    4749                 :            : 
    4750                 :      55701 :   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
    4751                 :            :     return NULL;
    4752                 :            : 
    4753                 :      51649 :   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
    4754                 :      51649 :   if (hidden
    4755                 :         24 :       && (!tmp_symtree || !tmp_symtree->n.sym
    4756                 :         14 :           || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
    4757                 :         14 :           || tmp_symtree->n.sym->intmod_sym_id != s))
    4758                 :         10 :     tmp_symtree = NULL;
    4759                 :            : 
    4760                 :            :   /* Already exists in this scope so don't re-add it.  */
    4761                 :        300 :   if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
    4762                 :        300 :       && (!tmp_sym->attr.generic
    4763                 :         34 :           || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
    4764                 :      51949 :       && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
    4765                 :            :     {
    4766                 :        300 :       if (tmp_sym->attr.flavor == FL_DERIVED
    4767                 :        313 :           && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
    4768                 :            :         {
    4769                 :         34 :           if (gfc_derived_types)
    4770                 :            :             {
    4771                 :         13 :               tmp_sym->dt_next = gfc_derived_types->dt_next;
    4772                 :         13 :               gfc_derived_types->dt_next = tmp_sym;
    4773                 :            :             }
    4774                 :            :           else
    4775                 :            :             {
    4776                 :         21 :               tmp_sym->dt_next = tmp_sym;
    4777                 :            :             }
    4778                 :         34 :           gfc_derived_types = tmp_sym;
    4779                 :            :         }
    4780                 :            : 
    4781                 :        300 :       return tmp_symtree;
    4782                 :            :     }
    4783                 :            : 
    4784                 :            :   /* Create the sym tree in the current ns.  */
    4785                 :      51349 :   if (hidden)
    4786                 :            :     {
    4787                 :         10 :       tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
    4788                 :         10 :       tmp_sym = gfc_new_symbol (name, gfc_current_ns);
    4789                 :            : 
    4790                 :            :       /* Add to the list of tentative symbols.  */
    4791                 :         10 :       latest_undo_chgset->syms.safe_push (tmp_sym);
    4792                 :         10 :       tmp_sym->old_symbol = NULL;
    4793                 :         10 :       tmp_sym->mark = 1;
    4794                 :         10 :       tmp_sym->gfc_new = 1;
    4795                 :            : 
    4796                 :         10 :       tmp_symtree->n.sym = tmp_sym;
    4797                 :         10 :       tmp_sym->refs++;
    4798                 :            :     }
    4799                 :            :   else
    4800                 :            :     {
    4801                 :      51339 :       gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    4802                 :      51339 :       gcc_assert (tmp_symtree);
    4803                 :      51339 :       tmp_sym = tmp_symtree->n.sym;
    4804                 :            :     }
    4805                 :            : 
    4806                 :            :   /* Say what module this symbol belongs to.  */
    4807                 :      51349 :   tmp_sym->module = gfc_get_string ("%s", mod_name);
    4808                 :      51349 :   tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
    4809                 :      51349 :   tmp_sym->intmod_sym_id = s;
    4810                 :      51349 :   tmp_sym->attr.is_iso_c = 1;
    4811                 :      51349 :   tmp_sym->attr.use_assoc = 1;
    4812                 :            : 
    4813                 :      51349 :   gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
    4814                 :            :               || s == ISOCBINDING_NULL_PTR);
    4815                 :            : 
    4816                 :      51349 :   switch (s)
    4817                 :            :     {
    4818                 :            : 
    4819                 :            : #define NAMED_INTCST(a,b,c,d) case a :
    4820                 :            : #define NAMED_REALCST(a,b,c,d) case a :
    4821                 :            : #define NAMED_CMPXCST(a,b,c,d) case a :
    4822                 :            : #define NAMED_LOGCST(a,b,c) case a :
    4823                 :            : #define NAMED_CHARKNDCST(a,b,c) case a :
    4824                 :            : #include "iso-c-binding.def"
    4825                 :            : 
    4826                 :      76946 :         tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
    4827                 :      38473 :                                            c_interop_kinds_table[s].value);
    4828                 :            : 
    4829                 :            :         /* Initialize an integer constant expression node.  */
    4830                 :      38473 :         tmp_sym->attr.flavor = FL_PARAMETER;
    4831                 :      38473 :         tmp_sym->ts.type = BT_INTEGER;
    4832                 :      38473 :         tmp_sym->ts.kind = gfc_default_integer_kind;
    4833                 :            : 
    4834                 :            :         /* Mark this type as a C interoperable one.  */
    4835                 :      38473 :         tmp_sym->ts.is_c_interop = 1;
    4836                 :      38473 :         tmp_sym->ts.is_iso_c = 1;
    4837                 :      38473 :         tmp_sym->value->ts.is_c_interop = 1;
    4838                 :      38473 :         tmp_sym->value->ts.is_iso_c = 1;
    4839                 :      38473 :         tmp_sym->attr.is_c_interop = 1;
    4840                 :            : 
    4841                 :            :         /* Tell what f90 type this c interop kind is valid.  */
    4842                 :      38473 :         tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
    4843                 :            : 
    4844                 :      38473 :         break;
    4845                 :            : 
    4846                 :            : 
    4847                 :            : #define NAMED_CHARCST(a,b,c) case a :
    4848                 :            : #include "iso-c-binding.def"
    4849                 :            : 
    4850                 :            :         /* Initialize an integer constant expression node for the
    4851                 :            :            length of the character.  */
    4852                 :       8352 :         tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
    4853                 :            :                                                  &gfc_current_locus, NULL, 1);
    4854                 :       8352 :         tmp_sym->value->ts.is_c_interop = 1;
    4855                 :       8352 :         tmp_sym->value->ts.is_iso_c = 1;
    4856                 :       8352 :         tmp_sym->value->value.character.length = 1;
    4857                 :       8352 :         tmp_sym->value->value.character.string[0]
    4858                 :       8352 :           = (gfc_char_t) c_interop_kinds_table[s].value;
    4859                 :       8352 :         tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    4860                 :       8352 :         tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
    4861                 :            :                                                      NULL, 1);
    4862                 :            : 
    4863                 :            :         /* May not need this in both attr and ts, but do need in
    4864                 :            :            attr for writing module file.  */
    4865                 :       8352 :         tmp_sym->attr.is_c_interop = 1;
    4866                 :            : 
    4867                 :       8352 :         tmp_sym->attr.flavor = FL_PARAMETER;
    4868                 :       8352 :         tmp_sym->ts.type = BT_CHARACTER;
    4869                 :            : 
    4870                 :            :         /* Need to set it to the C_CHAR kind.  */
    4871                 :       8352 :         tmp_sym->ts.kind = gfc_default_character_kind;
    4872                 :            : 
    4873                 :            :         /* Mark this type as a C interoperable one.  */
    4874                 :       8352 :         tmp_sym->ts.is_c_interop = 1;
    4875                 :       8352 :         tmp_sym->ts.is_iso_c = 1;
    4876                 :            : 
    4877                 :            :         /* Tell what f90 type this c interop kind is valid.  */
    4878                 :       8352 :         tmp_sym->ts.f90_type = BT_CHARACTER;
    4879                 :            : 
    4880                 :       8352 :         break;
    4881                 :            : 
    4882                 :       2385 :       case ISOCBINDING_PTR:
    4883                 :       2385 :       case ISOCBINDING_FUNPTR:
    4884                 :       2385 :         {
    4885                 :       2385 :           gfc_symbol *dt_sym;
    4886                 :       2385 :           gfc_component *tmp_comp = NULL;
    4887                 :            : 
    4888                 :            :           /* Generate real derived type.  */
    4889                 :       2385 :           if (hidden)
    4890                 :            :             dt_sym = tmp_sym;
    4891                 :            :           else
    4892                 :            :             {
    4893                 :       2375 :               const char *hidden_name;
    4894                 :       2375 :               gfc_interface *intr, *head;
    4895                 :            : 
    4896                 :       2375 :               hidden_name = gfc_dt_upper_string (tmp_sym->name);
    4897                 :       2375 :               tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
    4898                 :            :                                               hidden_name);
    4899                 :       2375 :               gcc_assert (tmp_symtree == NULL);
    4900                 :       2375 :               gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
    4901                 :       2375 :               dt_sym = tmp_symtree->n.sym;
    4902                 :       3494 :               dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
    4903                 :            :                                              ? "c_ptr" : "c_funptr");
    4904                 :            : 
    4905                 :            :               /* Generate an artificial generic function.  */
    4906                 :       2375 :               head = tmp_sym->generic;
    4907                 :       2375 :               intr = gfc_get_interface ();
    4908                 :       2375 :               intr->sym = dt_sym;
    4909                 :       2375 :               intr->where = gfc_current_locus;
    4910                 :       2375 :               intr->next = head;
    4911                 :       2375 :               tmp_sym->generic = intr;
    4912                 :            : 
    4913                 :       2375 :               if (!tmp_sym->attr.generic
    4914                 :       2375 :                   && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
    4915                 :          0 :                 return NULL;
    4916                 :            : 
    4917                 :       2375 :               if (!tmp_sym->attr.function
    4918                 :       2375 :                   && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
    4919                 :            :                 return NULL;
    4920                 :            :             }
    4921                 :            : 
    4922                 :            :           /* Say what module this symbol belongs to.  */
    4923                 :       2385 :           dt_sym->module = gfc_get_string ("%s", mod_name);
    4924                 :       2385 :           dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
    4925                 :       2385 :           dt_sym->intmod_sym_id = s;
    4926                 :       2385 :           dt_sym->attr.use_assoc = 1;
    4927                 :            : 
    4928                 :            :           /* Initialize an integer constant expression node.  */
    4929                 :       2385 :           dt_sym->attr.flavor = FL_DERIVED;
    4930                 :       2385 :           dt_sym->ts.is_c_interop = 1;
    4931                 :       2385 :           dt_sym->attr.is_c_interop = 1;
    4932                 :       2385 :           dt_sym->attr.private_comp = 1;
    4933                 :       2385 :           dt_sym->component_access = ACCESS_PRIVATE;
    4934                 :       2385 :           dt_sym->ts.is_iso_c = 1;
    4935                 :       2385 :           dt_sym->ts.type = BT_DERIVED;
    4936                 :       2385 :           dt_sym->ts.f90_type = BT_VOID;
    4937                 :            : 
    4938                 :            :           /* A derived type must have the bind attribute to be
    4939                 :            :              interoperable (J3/04-007, Section 15.2.3), even though
    4940                 :            :              the binding label is not used.  */
    4941                 :       2385 :           dt_sym->attr.is_bind_c = 1;
    4942                 :            : 
    4943                 :       2385 :           dt_sym->attr.referenced = 1;
    4944                 :       2385 :           dt_sym->ts.u.derived = dt_sym;
    4945                 :            : 
    4946                 :            :           /* Add the symbol created for the derived type to the current ns.  */
    4947                 :       2385 :           if (gfc_derived_types)
    4948                 :            :             {
    4949                 :       1461 :               dt_sym->dt_next = gfc_derived_types->dt_next;
    4950                 :       1461 :               gfc_derived_types->dt_next = dt_sym;
    4951                 :            :             }
    4952                 :            :           else
    4953                 :            :             {
    4954                 :        924 :               dt_sym->dt_next = dt_sym;
    4955                 :            :             }
    4956                 :       2385 :           gfc_derived_types = dt_sym;
    4957                 :            : 
    4958                 :       2385 :           gfc_add_component (dt_sym, "c_address", &tmp_comp);
    4959                 :       2385 :           if (tmp_comp == NULL)
    4960                 :          0 :             gcc_unreachable ();
    4961                 :            : 
    4962                 :       2385 :           tmp_comp->ts.type = BT_INTEGER;
    4963                 :            : 
    4964                 :            :           /* Set this because the module will need to read/write this field.  */
    4965                 :       2385 :           tmp_comp->ts.f90_type = BT_INTEGER;
    4966                 :            : 
    4967                 :            :           /* The kinds for c_ptr and c_funptr are the same.  */
    4968                 :       2385 :           index = get_c_kind ("c_ptr", c_interop_kinds_table);
    4969                 :       2385 :           tmp_comp->ts.kind = c_interop_kinds_table[index].value;
    4970                 :       2385 :           tmp_comp->attr.access = ACCESS_PRIVATE;
    4971                 :            : 
    4972                 :            :           /* Mark the component as C interoperable.  */
    4973                 :       2385 :           tmp_comp->ts.is_c_interop = 1;
    4974                 :            :         }
    4975                 :            : 
    4976                 :       2385 :         break;
    4977                 :            : 
    4978                 :       2139 :       case ISOCBINDING_NULL_PTR:
    4979                 :       2139 :       case ISOCBINDING_NULL_FUNPTR:
    4980                 :       2139 :         gen_special_c_interop_ptr (tmp_sym, dt_symtree);
    4981                 :       2139 :         break;
    4982                 :            : 
    4983                 :          0 :       default:
    4984                 :          0 :         gcc_unreachable ();
    4985                 :            :     }
    4986                 :      51349 :   gfc_commit_symbol (tmp_sym);
    4987                 :      51349 :   return tmp_symtree;
    4988                 :            : }
    4989                 :            : 
    4990                 :            : 
    4991                 :            : /* Check that a symbol is already typed.  If strict is not set, an untyped
    4992                 :            :    symbol is acceptable for non-standard-conforming mode.  */
    4993                 :            : 
    4994                 :            : bool
    4995                 :      10953 : gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
    4996                 :            :                         bool strict, locus where)
    4997                 :            : {
    4998                 :      10953 :   gcc_assert (sym);
    4999                 :            : 
    5000                 :      10953 :   if (gfc_matching_prefix)
    5001                 :            :     return true;
    5002                 :            : 
    5003                 :            :   /* Check for the type and try to give it an implicit one.  */
    5004                 :      10914 :   if (sym->ts.type == BT_UNKNOWN
    5005                 :      10914 :       && !gfc_set_default_type (sym, 0, ns))
    5006                 :            :     {
    5007                 :        403 :       if (strict)
    5008                 :            :         {
    5009                 :         11 :           gfc_error ("Symbol %qs is used before it is typed at %L",
    5010                 :            :                      sym->name, &where);
    5011                 :         11 :           return false;
    5012                 :            :         }
    5013                 :            : 
    5014                 :        392 :       if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before"
    5015                 :            :                            " it is typed at %L", sym->name, &where))
    5016                 :          3 :         return false;
    5017                 :            :     }
    5018                 :            : 
    5019                 :            :   /* Everything is ok.  */
    5020                 :            :   return true;
    5021                 :            : }
    5022                 :            : 
    5023                 :            : 
    5024                 :            : /* Construct a typebound-procedure structure.  Those are stored in a tentative
    5025                 :            :    list and marked `error' until symbols are committed.  */
    5026                 :            : 
    5027                 :            : gfc_typebound_proc*
    5028                 :      31658 : gfc_get_typebound_proc (gfc_typebound_proc *tb0)
    5029                 :            : {
    5030                 :      31658 :   gfc_typebound_proc *result;
    5031                 :            : 
    5032                 :      31658 :   result = XCNEW (gfc_typebound_proc);
    5033                 :      31658 :   if (tb0)
    5034                 :       2595 :     *result = *tb0;
    5035                 :      31658 :   result->error = 1;
    5036                 :            : 
    5037                 :      31658 :   latest_undo_chgset->tbps.safe_push (result);
    5038                 :            : 
    5039                 :      31658 :   return result;
    5040                 :            : }
    5041                 :            : 
    5042                 :            : 
    5043                 :            : /* Get the super-type of a given derived type.  */
    5044                 :            : 
    5045                 :            : gfc_symbol*
    5046                 :     449592 : gfc_get_derived_super_type (gfc_symbol* derived)
    5047                 :            : {
    5048                 :     449592 :   gcc_assert (derived);
    5049                 :            : 
    5050                 :     449592 :   if (derived->attr.generic)
    5051                 :          2 :     derived = gfc_find_dt_in_generic (derived);
    5052                 :            : 
    5053                 :     449592 :   if (!derived->attr.extension)
    5054                 :            :     return NULL;
    5055                 :            : 
    5056                 :      92651 :   gcc_assert (derived->components);
    5057                 :      92651 :   gcc_assert (derived->components->ts.type == BT_DERIVED);
    5058                 :      92651 :   gcc_assert (derived->components->ts.u.derived);
    5059                 :            : 
    5060                 :      92651 :   if (derived->components->ts.u.derived->attr.generic)
    5061                 :          0 :     return gfc_find_dt_in_generic (derived->components->ts.u.derived);
    5062                 :            : 
    5063                 :            :   return derived->components->ts.u.derived;
    5064                 :            : }
    5065                 :            : 
    5066                 :            : 
    5067                 :            : /* Get the ultimate super-type of a given derived type.  */
    5068                 :            : 
    5069                 :            : gfc_symbol*
    5070                 :          0 : gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
    5071                 :            : {
    5072                 :          0 :   if (!derived->attr.extension)
    5073                 :            :     return NULL;
    5074                 :            : 
    5075                 :          0 :   derived = gfc_get_derived_super_type (derived);
    5076                 :            : 
    5077                 :          0 :   if (derived->attr.extension)
    5078                 :            :     return gfc_get_ultimate_derived_super_type (derived);
    5079                 :            :   else
    5080                 :            :     return derived;
    5081                 :            : }
    5082                 :            : 
    5083                 :            : 
    5084                 :            : /* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
    5085                 :            : 
    5086                 :            : bool
    5087                 :      22044 : gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
    5088                 :            : {
    5089                 :      25686 :   while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
    5090                 :       3642 :     t2 = gfc_get_derived_super_type (t2);
    5091                 :      22043 :   return gfc_compare_derived_types (t1, t2);
    5092                 :            : }
    5093                 :            : 
    5094                 :            : 
    5095                 :            : /* Check if two typespecs are type compatible (F03:5.1.1.2):
    5096                 :            :    If ts1 is nonpolymorphic, ts2 must be the same type.
    5097                 :            :    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
    5098                 :            : 
    5099                 :            : bool
    5100                 :     135274 : gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
    5101                 :            : {
    5102                 :     135274 :   bool is_class1 = (ts1->type == BT_CLASS);
    5103                 :     135274 :   bool is_class2 = (ts2->type == BT_CLASS);
    5104                 :     135274 :   bool is_derived1 = (ts1->type == BT_DERIVED);
    5105                 :     135274 :   bool is_derived2 = (ts2->type == BT_DERIVED);
    5106                 :     135274 :   bool is_union1 = (ts1->type == BT_UNION);
    5107                 :     135274 :   bool is_union2 = (ts2->type == BT_UNION);
    5108                 :            : 
    5109                 :     135274 :   if (is_class1
    5110                 :      20692 :       && ts1->u.derived->components
    5111                 :      20529 :       && ((ts1->u.derived->attr.is_class
    5112                 :      20523 :            && ts1->u.derived->components->ts.u.derived->attr
    5113                 :      20529 :                                                         .unlimited_polymorphic)
    5114                 :      19997 :           || ts1->u.derived->attr.unlimited_polymorphic))
    5115                 :            :     return 1;
    5116                 :            : 
    5117                 :     134742 :   if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
    5118                 :       1047 :       && !is_union1 && !is_union2)
    5119                 :       1047 :     return (ts1->type == ts2->type);
    5120                 :            : 
    5121                 :     133695 :   if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
    5122                 :     112810 :     return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
    5123                 :            : 
    5124                 :      20885 :   if (is_derived1 && is_class2)
    5125                 :        721 :     return gfc_compare_derived_types (ts1->u.derived,
    5126                 :        721 :                                       ts2->u.derived->attr.is_class ?
    5127                 :        718 :                                       ts2->u.derived->components->ts.u.derived
    5128                 :       1442 :                                       : ts2->u.derived);
    5129                 :      20164 :   if (is_class1 && is_derived2)
    5130                 :       6081 :     return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
    5131                 :       6079 :                                        ts1->u.derived->components->ts.u.derived
    5132                 :       6081 :                                      : ts1->u.derived,
    5133                 :       6081 :                                      ts2->u.derived);
    5134                 :      14083 :   else if (is_class1 && is_class2)
    5135                 :      14079 :     return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
    5136                 :      13912 :                                        ts1->u.derived->components->ts.u.derived
    5137                 :      14079 :                                      : ts1->u.derived,
    5138                 :      14079 :                                      ts2->u.derived->attr.is_class ?
    5139                 :      13913 :                                        ts2->u.derived->components->ts.u.derived
    5140                 :      28158 :                                      : ts2->u.derived);
    5141                 :            :   else
    5142                 :            :     return 0;
    5143                 :            : }
    5144                 :            : 
    5145                 :            : 
    5146                 :            : /* Find the parent-namespace of the current function.  If we're inside
    5147                 :            :    BLOCK constructs, it may not be the current one.  */
    5148                 :            : 
    5149                 :            : gfc_namespace*
    5150                 :      48393 : gfc_find_proc_namespace (gfc_namespace* ns)
    5151                 :            : {
    5152                 :      48843 :   while (ns->construct_entities)
    5153                 :            :     {
    5154                 :        450 :       ns = ns->parent;
    5155                 :        450 :       gcc_assert (ns);
    5156                 :            :     }
    5157                 :            : 
    5158                 :      48393 :   return ns;
    5159                 :            : }
    5160                 :            : 
    5161                 :            : 
    5162                 :            : /* Check if an associate-variable should be translated as an `implicit' pointer
    5163                 :            :    internally (if it is associated to a variable and not an array with
    5164                 :            :    descriptor).  */
    5165                 :            : 
    5166                 :            : bool
    5167                 :     837995 : gfc_is_associate_pointer (gfc_symbol* sym)
    5168                 :            : {
    5169                 :     837995 :   if (!sym->assoc)
    5170                 :            :     return false;
    5171                 :            : 
    5172                 :       8922 :   if (sym->ts.type == BT_CLASS)
    5173                 :            :     return true;
    5174                 :            : 
    5175                 :       5431 :   if (sym->ts.type == BT_CHARACTER
    5176                 :        632 :       && sym->ts.deferred
    5177                 :         54 :       && sym->assoc->target
    5178                 :         54 :       && sym->assoc->target->expr_type == EXPR_FUNCTION)
    5179                 :            :     return true;
    5180                 :            : 
    5181                 :       5425 :   if (!sym->assoc->variable)
    5182                 :            :     return false;
    5183                 :            : 
    5184                 :       4798 :   if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
    5185                 :        730 :     return false;
    5186                 :            : 
    5187                 :            :   return true;
    5188                 :            : }
    5189                 :            : 
    5190                 :            : 
    5191                 :            : gfc_symbol *
    5192                 :      24114 : gfc_find_dt_in_generic (gfc_symbol *sym)
    5193                 :            : {
    5194                 :      24114 :   gfc_interface *intr = NULL;
    5195                 :            : 
    5196                 :      24114 :   if (!sym || gfc_fl_struct (sym->attr.flavor))
    5197                 :            :     return sym;
    5198                 :            : 
    5199                 :      24114 :   if (sym->attr.generic)
    5200                 :      25350 :     for (intr = sym->generic; intr; intr = intr->next)
    5201                 :      15721 :       if (gfc_fl_struct (intr->sym->attr.flavor))
    5202                 :            :         break;
    5203                 :      24113 :   return intr ? intr->sym : NULL;
    5204                 :            : }
    5205                 :            : 
    5206                 :            : 
    5207                 :            : /* Get the dummy arguments from a procedure symbol. If it has been declared
    5208                 :            :    via a PROCEDURE statement with a named interface, ts.interface will be set
    5209                 :            :    and the arguments need to be taken from there.  */
    5210                 :            : 
    5211                 :            : gfc_formal_arglist *
    5212                 :    1799560 : gfc_sym_get_dummy_args (gfc_symbol *sym)
    5213                 :            : {
    5214                 :    1799560 :   gfc_formal_arglist *dummies;
    5215                 :            : 
    5216                 :    1799560 :   dummies = sym->formal;
    5217                 :    1799560 :   if (dummies == NULL && sym->ts.interface != NULL)
    5218                 :       5049 :     dummies = sym->ts.interface->formal;
    5219                 :            : 
    5220                 :    1799560 :   return dummies;
    5221                 :            : }

Generated by: LCOV version 1.0

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