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

Generated by: LCOV version 2.0-1

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