LCOV - code coverage report
Current view: top level - gcc/fortran - trans-decl.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 3193 3322 96.1 %
Date: 2020-03-28 11:57:23 Functions: 83 87 95.4 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Backend function setup
       2                 :            :    Copyright (C) 2002-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Paul Brook
       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                 :            : /* trans-decl.c -- Handling of backend function and variable decls, etc */
      22                 :            : 
      23                 :            : #include "config.h"
      24                 :            : #include "system.h"
      25                 :            : #include "coretypes.h"
      26                 :            : #include "target.h"
      27                 :            : #include "function.h"
      28                 :            : #include "tree.h"
      29                 :            : #include "gfortran.h"
      30                 :            : #include "gimple-expr.h"      /* For create_tmp_var_raw.  */
      31                 :            : #include "trans.h"
      32                 :            : #include "stringpool.h"
      33                 :            : #include "cgraph.h"
      34                 :            : #include "fold-const.h"
      35                 :            : #include "stor-layout.h"
      36                 :            : #include "varasm.h"
      37                 :            : #include "attribs.h"
      38                 :            : #include "dumpfile.h"
      39                 :            : #include "toplev.h"   /* For announce_function.  */
      40                 :            : #include "debug.h"
      41                 :            : #include "constructor.h"
      42                 :            : #include "trans-types.h"
      43                 :            : #include "trans-array.h"
      44                 :            : #include "trans-const.h"
      45                 :            : #include "intrinsic.h"                /* For gfc_resolve_index_func.  */
      46                 :            : /* Only for gfc_trans_code.  Shouldn't need to include this.  */
      47                 :            : #include "trans-stmt.h"
      48                 :            : #include "gomp-constants.h"
      49                 :            : #include "gimplify.h"
      50                 :            : #include "omp-general.h"
      51                 :            : 
      52                 :            : #define MAX_LABEL_VALUE 99999
      53                 :            : 
      54                 :            : 
      55                 :            : /* Holds the result of the function if no result variable specified.  */
      56                 :            : 
      57                 :            : static GTY(()) tree current_fake_result_decl;
      58                 :            : static GTY(()) tree parent_fake_result_decl;
      59                 :            : 
      60                 :            : 
      61                 :            : /* Holds the variable DECLs for the current function.  */
      62                 :            : 
      63                 :            : static GTY(()) tree saved_function_decls;
      64                 :            : static GTY(()) tree saved_parent_function_decls;
      65                 :            : 
      66                 :            : /* Holds the variable DECLs that are locals.  */
      67                 :            : 
      68                 :            : static GTY(()) tree saved_local_decls;
      69                 :            : 
      70                 :            : /* The namespace of the module we're currently generating.  Only used while
      71                 :            :    outputting decls for module variables.  Do not rely on this being set.  */
      72                 :            : 
      73                 :            : static gfc_namespace *module_namespace;
      74                 :            : 
      75                 :            : /* The currently processed procedure symbol.  */
      76                 :            : static gfc_symbol* current_procedure_symbol = NULL;
      77                 :            : 
      78                 :            : /* The currently processed module.  */
      79                 :            : static struct module_htab_entry *cur_module;
      80                 :            : 
      81                 :            : /* With -fcoarray=lib: For generating the registering call
      82                 :            :    of static coarrays.  */
      83                 :            : static bool has_coarray_vars;
      84                 :            : static stmtblock_t caf_init_block;
      85                 :            : 
      86                 :            : 
      87                 :            : /* List of static constructor functions.  */
      88                 :            : 
      89                 :            : tree gfc_static_ctors;
      90                 :            : 
      91                 :            : 
      92                 :            : /* Whether we've seen a symbol from an IEEE module in the namespace.  */
      93                 :            : static int seen_ieee_symbol;
      94                 :            : 
      95                 :            : /* Function declarations for builtin library functions.  */
      96                 :            : 
      97                 :            : tree gfor_fndecl_pause_numeric;
      98                 :            : tree gfor_fndecl_pause_string;
      99                 :            : tree gfor_fndecl_stop_numeric;
     100                 :            : tree gfor_fndecl_stop_string;
     101                 :            : tree gfor_fndecl_error_stop_numeric;
     102                 :            : tree gfor_fndecl_error_stop_string;
     103                 :            : tree gfor_fndecl_runtime_error;
     104                 :            : tree gfor_fndecl_runtime_error_at;
     105                 :            : tree gfor_fndecl_runtime_warning_at;
     106                 :            : tree gfor_fndecl_os_error_at;
     107                 :            : tree gfor_fndecl_generate_error;
     108                 :            : tree gfor_fndecl_set_args;
     109                 :            : tree gfor_fndecl_set_fpe;
     110                 :            : tree gfor_fndecl_set_options;
     111                 :            : tree gfor_fndecl_set_convert;
     112                 :            : tree gfor_fndecl_set_record_marker;
     113                 :            : tree gfor_fndecl_set_max_subrecord_length;
     114                 :            : tree gfor_fndecl_ctime;
     115                 :            : tree gfor_fndecl_fdate;
     116                 :            : tree gfor_fndecl_ttynam;
     117                 :            : tree gfor_fndecl_in_pack;
     118                 :            : tree gfor_fndecl_in_unpack;
     119                 :            : tree gfor_fndecl_cfi_to_gfc;
     120                 :            : tree gfor_fndecl_gfc_to_cfi;
     121                 :            : tree gfor_fndecl_associated;
     122                 :            : tree gfor_fndecl_system_clock4;
     123                 :            : tree gfor_fndecl_system_clock8;
     124                 :            : tree gfor_fndecl_ieee_procedure_entry;
     125                 :            : tree gfor_fndecl_ieee_procedure_exit;
     126                 :            : 
     127                 :            : /* Coarray run-time library function decls.  */
     128                 :            : tree gfor_fndecl_caf_init;
     129                 :            : tree gfor_fndecl_caf_finalize;
     130                 :            : tree gfor_fndecl_caf_this_image;
     131                 :            : tree gfor_fndecl_caf_num_images;
     132                 :            : tree gfor_fndecl_caf_register;
     133                 :            : tree gfor_fndecl_caf_deregister;
     134                 :            : tree gfor_fndecl_caf_get;
     135                 :            : tree gfor_fndecl_caf_send;
     136                 :            : tree gfor_fndecl_caf_sendget;
     137                 :            : tree gfor_fndecl_caf_get_by_ref;
     138                 :            : tree gfor_fndecl_caf_send_by_ref;
     139                 :            : tree gfor_fndecl_caf_sendget_by_ref;
     140                 :            : tree gfor_fndecl_caf_sync_all;
     141                 :            : tree gfor_fndecl_caf_sync_memory;
     142                 :            : tree gfor_fndecl_caf_sync_images;
     143                 :            : tree gfor_fndecl_caf_stop_str;
     144                 :            : tree gfor_fndecl_caf_stop_numeric;
     145                 :            : tree gfor_fndecl_caf_error_stop;
     146                 :            : tree gfor_fndecl_caf_error_stop_str;
     147                 :            : tree gfor_fndecl_caf_atomic_def;
     148                 :            : tree gfor_fndecl_caf_atomic_ref;
     149                 :            : tree gfor_fndecl_caf_atomic_cas;
     150                 :            : tree gfor_fndecl_caf_atomic_op;
     151                 :            : tree gfor_fndecl_caf_lock;
     152                 :            : tree gfor_fndecl_caf_unlock;
     153                 :            : tree gfor_fndecl_caf_event_post;
     154                 :            : tree gfor_fndecl_caf_event_wait;
     155                 :            : tree gfor_fndecl_caf_event_query;
     156                 :            : tree gfor_fndecl_caf_fail_image;
     157                 :            : tree gfor_fndecl_caf_failed_images;
     158                 :            : tree gfor_fndecl_caf_image_status;
     159                 :            : tree gfor_fndecl_caf_stopped_images;
     160                 :            : tree gfor_fndecl_caf_form_team;
     161                 :            : tree gfor_fndecl_caf_change_team;
     162                 :            : tree gfor_fndecl_caf_end_team;
     163                 :            : tree gfor_fndecl_caf_sync_team;
     164                 :            : tree gfor_fndecl_caf_get_team;
     165                 :            : tree gfor_fndecl_caf_team_number;
     166                 :            : tree gfor_fndecl_co_broadcast;
     167                 :            : tree gfor_fndecl_co_max;
     168                 :            : tree gfor_fndecl_co_min;
     169                 :            : tree gfor_fndecl_co_reduce;
     170                 :            : tree gfor_fndecl_co_sum;
     171                 :            : tree gfor_fndecl_caf_is_present;
     172                 :            : 
     173                 :            : 
     174                 :            : /* Math functions.  Many other math functions are handled in
     175                 :            :    trans-intrinsic.c.  */
     176                 :            : 
     177                 :            : gfc_powdecl_list gfor_fndecl_math_powi[4][3];
     178                 :            : tree gfor_fndecl_math_ishftc4;
     179                 :            : tree gfor_fndecl_math_ishftc8;
     180                 :            : tree gfor_fndecl_math_ishftc16;
     181                 :            : 
     182                 :            : 
     183                 :            : /* String functions.  */
     184                 :            : 
     185                 :            : tree gfor_fndecl_compare_string;
     186                 :            : tree gfor_fndecl_concat_string;
     187                 :            : tree gfor_fndecl_string_len_trim;
     188                 :            : tree gfor_fndecl_string_index;
     189                 :            : tree gfor_fndecl_string_scan;
     190                 :            : tree gfor_fndecl_string_verify;
     191                 :            : tree gfor_fndecl_string_trim;
     192                 :            : tree gfor_fndecl_string_minmax;
     193                 :            : tree gfor_fndecl_adjustl;
     194                 :            : tree gfor_fndecl_adjustr;
     195                 :            : tree gfor_fndecl_select_string;
     196                 :            : tree gfor_fndecl_compare_string_char4;
     197                 :            : tree gfor_fndecl_concat_string_char4;
     198                 :            : tree gfor_fndecl_string_len_trim_char4;
     199                 :            : tree gfor_fndecl_string_index_char4;
     200                 :            : tree gfor_fndecl_string_scan_char4;
     201                 :            : tree gfor_fndecl_string_verify_char4;
     202                 :            : tree gfor_fndecl_string_trim_char4;
     203                 :            : tree gfor_fndecl_string_minmax_char4;
     204                 :            : tree gfor_fndecl_adjustl_char4;
     205                 :            : tree gfor_fndecl_adjustr_char4;
     206                 :            : tree gfor_fndecl_select_string_char4;
     207                 :            : 
     208                 :            : 
     209                 :            : /* Conversion between character kinds.  */
     210                 :            : tree gfor_fndecl_convert_char1_to_char4;
     211                 :            : tree gfor_fndecl_convert_char4_to_char1;
     212                 :            : 
     213                 :            : 
     214                 :            : /* Other misc. runtime library functions.  */
     215                 :            : tree gfor_fndecl_size0;
     216                 :            : tree gfor_fndecl_size1;
     217                 :            : tree gfor_fndecl_iargc;
     218                 :            : tree gfor_fndecl_kill;
     219                 :            : tree gfor_fndecl_kill_sub;
     220                 :            : tree gfor_fndecl_is_contiguous0;
     221                 :            : 
     222                 :            : 
     223                 :            : /* Intrinsic functions implemented in Fortran.  */
     224                 :            : tree gfor_fndecl_sc_kind;
     225                 :            : tree gfor_fndecl_si_kind;
     226                 :            : tree gfor_fndecl_sr_kind;
     227                 :            : 
     228                 :            : /* BLAS gemm functions.  */
     229                 :            : tree gfor_fndecl_sgemm;
     230                 :            : tree gfor_fndecl_dgemm;
     231                 :            : tree gfor_fndecl_cgemm;
     232                 :            : tree gfor_fndecl_zgemm;
     233                 :            : 
     234                 :            : /* RANDOM_INIT function.  */
     235                 :            : tree gfor_fndecl_random_init;
     236                 :            : 
     237                 :            : static void
     238                 :       3002 : gfc_add_decl_to_parent_function (tree decl)
     239                 :            : {
     240                 :       3002 :   gcc_assert (decl);
     241                 :       3002 :   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
     242                 :       3002 :   DECL_NONLOCAL (decl) = 1;
     243                 :       3002 :   DECL_CHAIN (decl) = saved_parent_function_decls;
     244                 :       3002 :   saved_parent_function_decls = decl;
     245                 :       3002 : }
     246                 :            : 
     247                 :            : void
     248                 :     199850 : gfc_add_decl_to_function (tree decl)
     249                 :            : {
     250                 :     199850 :   gcc_assert (decl);
     251                 :     199850 :   TREE_USED (decl) = 1;
     252                 :     199850 :   DECL_CONTEXT (decl) = current_function_decl;
     253                 :     199850 :   DECL_CHAIN (decl) = saved_function_decls;
     254                 :     199850 :   saved_function_decls = decl;
     255                 :     199850 : }
     256                 :            : 
     257                 :            : static void
     258                 :       7691 : add_decl_as_local (tree decl)
     259                 :            : {
     260                 :       7691 :   gcc_assert (decl);
     261                 :       7691 :   TREE_USED (decl) = 1;
     262                 :       7691 :   DECL_CONTEXT (decl) = current_function_decl;
     263                 :       7691 :   DECL_CHAIN (decl) = saved_local_decls;
     264                 :       7691 :   saved_local_decls = decl;
     265                 :       7691 : }
     266                 :            : 
     267                 :            : 
     268                 :            : /* Build a  backend label declaration.  Set TREE_USED for named labels.
     269                 :            :    The context of the label is always the current_function_decl.  All
     270                 :            :    labels are marked artificial.  */
     271                 :            : 
     272                 :            : tree
     273                 :     343863 : gfc_build_label_decl (tree label_id)
     274                 :            : {
     275                 :            :   /* 2^32 temporaries should be enough.  */
     276                 :     343863 :   static unsigned int tmp_num = 1;
     277                 :     343863 :   tree label_decl;
     278                 :     343863 :   char *label_name;
     279                 :            : 
     280                 :     343863 :   if (label_id == NULL_TREE)
     281                 :            :     {
     282                 :            :       /* Build an internal label name.  */
     283                 :     340395 :       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
     284                 :     340395 :       label_id = get_identifier (label_name);
     285                 :            :     }
     286                 :            :   else
     287                 :     343863 :     label_name = NULL;
     288                 :            : 
     289                 :            :   /* Build the LABEL_DECL node. Labels have no type.  */
     290                 :     343863 :   label_decl = build_decl (input_location,
     291                 :            :                            LABEL_DECL, label_id, void_type_node);
     292                 :     343863 :   DECL_CONTEXT (label_decl) = current_function_decl;
     293                 :     343863 :   SET_DECL_MODE (label_decl, VOIDmode);
     294                 :            : 
     295                 :            :   /* We always define the label as used, even if the original source
     296                 :            :      file never references the label.  We don't want all kinds of
     297                 :            :      spurious warnings for old-style Fortran code with too many
     298                 :            :      labels.  */
     299                 :     343863 :   TREE_USED (label_decl) = 1;
     300                 :            : 
     301                 :     343863 :   DECL_ARTIFICIAL (label_decl) = 1;
     302                 :     343863 :   return label_decl;
     303                 :            : }
     304                 :            : 
     305                 :            : 
     306                 :            : /* Set the backend source location of a decl.  */
     307                 :            : 
     308                 :            : void
     309                 :     115806 : gfc_set_decl_location (tree decl, locus * loc)
     310                 :            : {
     311                 :     115806 :   DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc);
     312                 :     115806 : }
     313                 :            : 
     314                 :            : 
     315                 :            : /* Return the backend label declaration for a given label structure,
     316                 :            :    or create it if it doesn't exist yet.  */
     317                 :            : 
     318                 :            : tree
     319                 :       5826 : gfc_get_label_decl (gfc_st_label * lp)
     320                 :            : {
     321                 :       5826 :   if (lp->backend_decl)
     322                 :            :     return lp->backend_decl;
     323                 :            :   else
     324                 :            :     {
     325                 :       3468 :       char label_name[GFC_MAX_SYMBOL_LEN + 1];
     326                 :       3468 :       tree label_decl;
     327                 :            : 
     328                 :            :       /* Validate the label declaration from the front end.  */
     329                 :       3468 :       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
     330                 :            : 
     331                 :            :       /* Build a mangled name for the label.  */
     332                 :       3468 :       sprintf (label_name, "__label_%.6d", lp->value);
     333                 :            : 
     334                 :            :       /* Build the LABEL_DECL node.  */
     335                 :       3468 :       label_decl = gfc_build_label_decl (get_identifier (label_name));
     336                 :            : 
     337                 :            :       /* Tell the debugger where the label came from.  */
     338                 :       3468 :       if (lp->value <= MAX_LABEL_VALUE)   /* An internal label.  */
     339                 :       3468 :         gfc_set_decl_location (label_decl, &lp->where);
     340                 :            :       else
     341                 :          0 :         DECL_ARTIFICIAL (label_decl) = 1;
     342                 :            : 
     343                 :            :       /* Store the label in the label list and return the LABEL_DECL.  */
     344                 :       3468 :       lp->backend_decl = label_decl;
     345                 :       3468 :       return label_decl;
     346                 :            :     }
     347                 :            : }
     348                 :            : 
     349                 :            : /* Return the name of an identifier.  */
     350                 :            : 
     351                 :            : static const char *
     352                 :     275688 : sym_identifier (gfc_symbol *sym)
     353                 :            : {
     354                 :      21186 :   if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
     355                 :            :     return "MAIN__";
     356                 :            :   else
     357                 :     272032 :     return sym->name;
     358                 :            : }
     359                 :            : 
     360                 :            : /* Convert a gfc_symbol to an identifier of the same name.  */
     361                 :            : 
     362                 :            : static tree
     363                 :     275688 : gfc_sym_identifier (gfc_symbol * sym)
     364                 :            : {
     365                 :     551376 :   return get_identifier (sym_identifier (sym));
     366                 :            : }
     367                 :            : 
     368                 :            : /* Construct mangled name from symbol name.   */
     369                 :            : 
     370                 :            : static const char *
     371                 :      11615 : mangled_identifier (gfc_symbol *sym)
     372                 :            : {
     373                 :      11615 :   gfc_symbol *proc = sym->ns->proc_name;
     374                 :      11615 :   static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14];
     375                 :            :   /* Prevent the mangling of identifiers that have an assigned
     376                 :            :      binding label (mainly those that are bind(c)).  */
     377                 :            : 
     378                 :      11615 :   if (sym->attr.is_bind_c == 1 && sym->binding_label)
     379                 :            :     return sym->binding_label;
     380                 :            : 
     381                 :      11514 :   if (!sym->fn_result_spec
     382                 :         26 :       || (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE)))
     383                 :            :     {
     384                 :      11496 :       if (sym->module == NULL)
     385                 :          0 :         return sym_identifier (sym);
     386                 :            :       else
     387                 :      11496 :         snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
     388                 :            :     }
     389                 :            :   else
     390                 :            :     {
     391                 :            :       /* This is an entity that is actually local to a module procedure
     392                 :            :          that appears in the result specification expression.  Since
     393                 :            :          sym->module will be a zero length string, we use ns->proc_name
     394                 :            :          to provide the module name instead. */
     395                 :         18 :       if (proc && proc->module)
     396                 :         18 :         snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s",
     397                 :            :                   proc->module, proc->name, sym->name);
     398                 :            :       else
     399                 :          0 :         snprintf (name, sizeof name, "__%s_PROC_%s",
     400                 :            :                   proc->name, sym->name);
     401                 :            :     }
     402                 :            : 
     403                 :            :   return name;
     404                 :            : }
     405                 :            : 
     406                 :            : /* Get mangled identifier, adding the symbol to the global table if
     407                 :            :    it is not yet already there.  */
     408                 :            : 
     409                 :            : static tree
     410                 :      11478 : gfc_sym_mangled_identifier (gfc_symbol * sym)
     411                 :            : {
     412                 :      11478 :   tree result;
     413                 :      11478 :   gfc_gsymbol *gsym;
     414                 :      11478 :   const char *name;
     415                 :            : 
     416                 :      11478 :   name = mangled_identifier (sym);
     417                 :      11478 :   result = get_identifier (name);
     418                 :            : 
     419                 :      11478 :   gsym = gfc_find_gsymbol (gfc_gsym_root, name);
     420                 :      11478 :   if (gsym == NULL)
     421                 :            :     {
     422                 :      11354 :       gsym = gfc_get_gsymbol (name, false);
     423                 :      11354 :       gsym->ns = sym->ns;
     424                 :      11354 :       gsym->sym_name = sym->name;
     425                 :            :     }
     426                 :            : 
     427                 :      11478 :   return result;
     428                 :            : }
     429                 :            : 
     430                 :            : /* Construct mangled function name from symbol name.  */
     431                 :            : 
     432                 :            : static tree
     433                 :      62493 : gfc_sym_mangled_function_id (gfc_symbol * sym)
     434                 :            : {
     435                 :      62493 :   int has_underscore;
     436                 :      62493 :   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
     437                 :            : 
     438                 :            :   /* It may be possible to simply use the binding label if it's
     439                 :            :      provided, and remove the other checks.  Then we could use it
     440                 :            :      for other things if we wished.  */
     441                 :      62493 :   if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
     442                 :       1291 :       sym->binding_label)
     443                 :            :     /* use the binding label rather than the mangled name */
     444                 :       1281 :     return get_identifier (sym->binding_label);
     445                 :            : 
     446                 :      61212 :   if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
     447                 :      16976 :       || (sym->module != NULL && (sym->attr.external
     448                 :      16976 :             || sym->attr.if_source == IFSRC_IFBODY)))
     449                 :      44980 :       && !sym->attr.module_procedure)
     450                 :            :     {
     451                 :            :       /* Main program is mangled into MAIN__.  */
     452                 :      44736 :       if (sym->attr.is_main_program)
     453                 :      21186 :         return get_identifier ("MAIN__");
     454                 :            : 
     455                 :            :       /* Intrinsic procedures are never mangled.  */
     456                 :      23550 :       if (sym->attr.proc == PROC_INTRINSIC)
     457                 :      11202 :         return get_identifier (sym->name);
     458                 :            : 
     459                 :      12348 :       if (flag_underscoring)
     460                 :            :         {
     461                 :      11553 :           has_underscore = strchr (sym->name, '_') != 0;
     462                 :      11553 :           if (flag_second_underscore && has_underscore)
     463                 :        246 :             snprintf (name, sizeof name, "%s__", sym->name);
     464                 :            :           else
     465                 :      11307 :             snprintf (name, sizeof name, "%s_", sym->name);
     466                 :      11553 :           return get_identifier (name);
     467                 :            :         }
     468                 :            :       else
     469                 :        795 :         return get_identifier (sym->name);
     470                 :            :     }
     471                 :            :   else
     472                 :            :     {
     473                 :      16476 :       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
     474                 :      16476 :       return get_identifier (name);
     475                 :            :     }
     476                 :            : }
     477                 :            : 
     478                 :            : 
     479                 :            : void
     480                 :      76260 : gfc_set_decl_assembler_name (tree decl, tree name)
     481                 :            : {
     482                 :      76260 :   tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
     483                 :      76260 :   SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
     484                 :      76260 : }
     485                 :            : 
     486                 :            : 
     487                 :            : /* Returns true if a variable of specified size should go on the stack.  */
     488                 :            : 
     489                 :            : int
     490                 :     146038 : gfc_can_put_var_on_stack (tree size)
     491                 :            : {
     492                 :     146038 :   unsigned HOST_WIDE_INT low;
     493                 :            : 
     494                 :     146038 :   if (!INTEGER_CST_P (size))
     495                 :            :     return 0;
     496                 :            : 
     497                 :     140753 :   if (flag_max_stack_var_size < 0)
     498                 :            :     return 1;
     499                 :            : 
     500                 :     126748 :   if (!tree_fits_uhwi_p (size))
     501                 :            :     return 0;
     502                 :            : 
     503                 :     126748 :   low = TREE_INT_CST_LOW (size);
     504                 :     126748 :   if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
     505                 :        595 :     return 0;
     506                 :            : 
     507                 :            : /* TODO: Set a per-function stack size limit.  */
     508                 :            : 
     509                 :            :   return 1;
     510                 :            : }
     511                 :            : 
     512                 :            : 
     513                 :            : /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
     514                 :            :    an expression involving its corresponding pointer.  There are
     515                 :            :    2 cases; one for variable size arrays, and one for everything else,
     516                 :            :    because variable-sized arrays require one fewer level of
     517                 :            :    indirection.  */
     518                 :            : 
     519                 :            : static void
     520                 :        264 : gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
     521                 :            : {
     522                 :        264 :   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
     523                 :        264 :   tree value;
     524                 :            : 
     525                 :            :   /* Parameters need to be dereferenced.  */
     526                 :        264 :   if (sym->cp_pointer->attr.dummy)
     527                 :          1 :     ptr_decl = build_fold_indirect_ref_loc (input_location,
     528                 :            :                                         ptr_decl);
     529                 :            : 
     530                 :            :   /* Check to see if we're dealing with a variable-sized array.  */
     531                 :        264 :   if (sym->attr.dimension
     532                 :        500 :       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
     533                 :            :     {
     534                 :            :       /* These decls will be dereferenced later, so we don't dereference
     535                 :            :          them here.  */
     536                 :        140 :       value = convert (TREE_TYPE (decl), ptr_decl);
     537                 :            :     }
     538                 :            :   else
     539                 :            :     {
     540                 :        124 :       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
     541                 :            :                           ptr_decl);
     542                 :        124 :       value = build_fold_indirect_ref_loc (input_location,
     543                 :            :                                        ptr_decl);
     544                 :            :     }
     545                 :            : 
     546                 :        264 :   SET_DECL_VALUE_EXPR (decl, value);
     547                 :        264 :   DECL_HAS_VALUE_EXPR_P (decl) = 1;
     548                 :        264 :   GFC_DECL_CRAY_POINTEE (decl) = 1;
     549                 :        264 : }
     550                 :            : 
     551                 :            : 
     552                 :            : /* Finish processing of a declaration without an initial value.  */
     553                 :            : 
     554                 :            : static void
     555                 :     118280 : gfc_finish_decl (tree decl)
     556                 :            : {
     557                 :     118968 :   gcc_assert (TREE_CODE (decl) == PARM_DECL
     558                 :            :               || DECL_INITIAL (decl) == NULL_TREE);
     559                 :            : 
     560                 :     118280 :   if (!VAR_P (decl))
     561                 :            :     return;
     562                 :            : 
     563                 :        688 :   if (DECL_SIZE (decl) == NULL_TREE
     564                 :        688 :       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
     565                 :          0 :     layout_decl (decl, 0);
     566                 :            : 
     567                 :            :   /* A few consistency checks.  */
     568                 :            :   /* A static variable with an incomplete type is an error if it is
     569                 :            :      initialized. Also if it is not file scope. Otherwise, let it
     570                 :            :      through, but if it is not `extern' then it may cause an error
     571                 :            :      message later.  */
     572                 :            :   /* An automatic variable with an incomplete type is an error.  */
     573                 :            : 
     574                 :            :   /* We should know the storage size.  */
     575                 :        688 :   gcc_assert (DECL_SIZE (decl) != NULL_TREE
     576                 :            :               || (TREE_STATIC (decl)
     577                 :            :                   ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
     578                 :            :                   : DECL_EXTERNAL (decl)));
     579                 :            : 
     580                 :            :   /* The storage size should be constant.  */
     581                 :        688 :   gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
     582                 :            :               || !DECL_SIZE (decl)
     583                 :            :               || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
     584                 :            : }
     585                 :            : 
     586                 :            : 
     587                 :            : /* Handle setting of GFC_DECL_SCALAR* on DECL.  */
     588                 :            : 
     589                 :            : void
     590                 :     271797 : gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
     591                 :            : {
     592                 :     271797 :   if (!attr->dimension && !attr->codimension)
     593                 :            :     {
     594                 :            :       /* Handle scalar allocatable variables.  */
     595                 :     218128 :       if (attr->allocatable)
     596                 :            :         {
     597                 :       4177 :           gfc_allocate_lang_decl (decl);
     598                 :       4177 :           GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
     599                 :            :         }
     600                 :            :       /* Handle scalar pointer variables.  */
     601                 :     218128 :       if (attr->pointer)
     602                 :            :         {
     603                 :      25586 :           gfc_allocate_lang_decl (decl);
     604                 :      25586 :           GFC_DECL_SCALAR_POINTER (decl) = 1;
     605                 :            :         }
     606                 :            :     }
     607                 :     271797 : }
     608                 :            : 
     609                 :            : 
     610                 :            : /* Apply symbol attributes to a variable, and add it to the function scope.  */
     611                 :            : 
     612                 :            : static void
     613                 :     122011 : gfc_finish_var_decl (tree decl, gfc_symbol * sym)
     614                 :            : {
     615                 :     122011 :   tree new_type;
     616                 :            : 
     617                 :            :   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
     618                 :     122011 :   if (sym->attr.cray_pointee)
     619                 :        264 :     gfc_finish_cray_pointee (decl, sym);
     620                 :            : 
     621                 :            :   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
     622                 :            :      This is the equivalent of the TARGET variables.
     623                 :            :      We also need to set this if the variable is passed by reference in a
     624                 :            :      CALL statement.  */
     625                 :     122011 :   if (sym->attr.target)
     626                 :      16477 :     TREE_ADDRESSABLE (decl) = 1;
     627                 :            : 
     628                 :            :   /* If it wasn't used we wouldn't be getting it.  */
     629                 :     122011 :   TREE_USED (decl) = 1;
     630                 :            : 
     631                 :     122011 :   if (sym->attr.flavor == FL_PARAMETER
     632                 :        786 :       && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
     633                 :        786 :     TREE_READONLY (decl) = 1;
     634                 :            : 
     635                 :            :   /* Chain this decl to the pending declarations.  Don't do pushdecl()
     636                 :            :      because this would add them to the current scope rather than the
     637                 :            :      function scope.  */
     638                 :     122011 :   if (current_function_decl != NULL_TREE)
     639                 :            :     {
     640                 :     110670 :       if (sym->ns->proc_name
     641                 :     110664 :           && (sym->ns->proc_name->backend_decl == current_function_decl
     642                 :      10593 :               || sym->result == sym))
     643                 :     100071 :         gfc_add_decl_to_function (decl);
     644                 :      10599 :       else if (sym->ns->proc_name
     645                 :      10593 :                && sym->ns->proc_name->attr.flavor == FL_LABEL)
     646                 :            :         /* This is a BLOCK construct.  */
     647                 :       7691 :         add_decl_as_local (decl);
     648                 :            :       else
     649                 :       2908 :         gfc_add_decl_to_parent_function (decl);
     650                 :            :     }
     651                 :            : 
     652                 :     122011 :   if (sym->attr.cray_pointee)
     653                 :            :     return;
     654                 :            : 
     655                 :     121747 :   if(sym->attr.is_bind_c == 1 && sym->binding_label)
     656                 :            :     {
     657                 :            :       /* We need to put variables that are bind(c) into the common
     658                 :            :          segment of the object file, because this is what C would do.
     659                 :            :          gfortran would typically put them in either the BSS or
     660                 :            :          initialized data segments, and only mark them as common if
     661                 :            :          they were part of common blocks.  However, if they are not put
     662                 :            :          into common space, then C cannot initialize global Fortran
     663                 :            :          variables that it interoperates with and the draft says that
     664                 :            :          either Fortran or C should be able to initialize it (but not
     665                 :            :          both, of course.) (J3/04-007, section 15.3).  */
     666                 :        101 :       TREE_PUBLIC(decl) = 1;
     667                 :        101 :       DECL_COMMON(decl) = 1;
     668                 :        101 :       if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
     669                 :            :         {
     670                 :          2 :           DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
     671                 :          2 :           DECL_VISIBILITY_SPECIFIED (decl) = true;
     672                 :            :         }
     673                 :            :     }
     674                 :            : 
     675                 :            :   /* If a variable is USE associated, it's always external.  */
     676                 :     121747 :   if (sym->attr.use_assoc || sym->attr.used_in_submodule)
     677                 :            :     {
     678                 :         65 :       DECL_EXTERNAL (decl) = 1;
     679                 :         65 :       TREE_PUBLIC (decl) = 1;
     680                 :            :     }
     681                 :     121682 :   else if (sym->fn_result_spec && !sym->ns->proc_name->module)
     682                 :            :     {
     683                 :            : 
     684                 :          0 :       if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
     685                 :          0 :         DECL_EXTERNAL (decl) = 1;
     686                 :            :       else
     687                 :          0 :         TREE_STATIC (decl) = 1;
     688                 :            : 
     689                 :          0 :       TREE_PUBLIC (decl) = 1;
     690                 :            :     }
     691                 :     121682 :   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
     692                 :            :     {
     693                 :            :       /* TODO: Don't set sym->module for result or dummy variables.  */
     694                 :      11339 :       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
     695                 :            : 
     696                 :      11339 :       TREE_PUBLIC (decl) = 1;
     697                 :      11339 :       TREE_STATIC (decl) = 1;
     698                 :      11339 :       if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
     699                 :            :         {
     700                 :        125 :           DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
     701                 :        125 :           DECL_VISIBILITY_SPECIFIED (decl) = true;
     702                 :            :         }
     703                 :            :     }
     704                 :            : 
     705                 :            :   /* Derived types are a bit peculiar because of the possibility of
     706                 :            :      a default initializer; this must be applied each time the variable
     707                 :            :      comes into scope it therefore need not be static.  These variables
     708                 :            :      are SAVE_NONE but have an initializer.  Otherwise explicitly
     709                 :            :      initialized variables are SAVE_IMPLICIT and explicitly saved are
     710                 :            :      SAVE_EXPLICIT.  */
     711                 :     121747 :   if (!sym->attr.use_assoc
     712                 :     121682 :         && (sym->attr.save != SAVE_NONE || sym->attr.data
     713                 :      99872 :             || (sym->value && sym->ns->proc_name->attr.is_main_program)
     714                 :      96737 :             || (flag_coarray == GFC_FCOARRAY_LIB
     715                 :        919 :                 && sym->attr.codimension && !sym->attr.allocatable)))
     716                 :      25038 :     TREE_STATIC (decl) = 1;
     717                 :            : 
     718                 :            :   /* If derived-type variables with DTIO procedures are not made static
     719                 :            :      some bits of code referencing them get optimized away.
     720                 :            :      TODO Understand why this is so and fix it.  */
     721                 :     121747 :   if (!sym->attr.use_assoc
     722                 :     121682 :       && ((sym->ts.type == BT_DERIVED
     723                 :      22843 :            && sym->ts.u.derived->attr.has_dtio_procs)
     724                 :     121285 :           || (sym->ts.type == BT_CLASS
     725                 :       3000 :               && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
     726                 :        421 :     TREE_STATIC (decl) = 1;
     727                 :            : 
     728                 :            :   /* Treat asynchronous variables the same as volatile, for now.  */
     729                 :     121747 :   if (sym->attr.volatile_ || sym->attr.asynchronous)
     730                 :            :     {
     731                 :        543 :       TREE_THIS_VOLATILE (decl) = 1;
     732                 :        543 :       TREE_SIDE_EFFECTS (decl) = 1;
     733                 :        543 :       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
     734                 :        543 :       TREE_TYPE (decl) = new_type;
     735                 :            :     }
     736                 :            : 
     737                 :            :   /* Keep variables larger than max-stack-var-size off stack.  */
     738                 :     121741 :   if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive)
     739                 :     109236 :       && !sym->attr.automatic
     740                 :     109218 :       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
     741                 :     108860 :       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
     742                 :            :          /* Put variable length auto array pointers always into stack.  */
     743                 :        482 :       && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
     744                 :         43 :           || sym->attr.dimension == 0
     745                 :          7 :           || sym->as->type != AS_EXPLICIT
     746                 :            :           || sym->attr.pointer
     747                 :          7 :           || sym->attr.allocatable)
     748                 :     122222 :       && !DECL_ARTIFICIAL (decl))
     749                 :            :     {
     750                 :        450 :       if (flag_max_stack_var_size > 0)
     751                 :        284 :         gfc_warning (OPT_Wsurprising,
     752                 :            :                      "Array %qs at %L is larger than limit set by"
     753                 :            :                      " %<-fmax-stack-var-size=%>, moved from stack to static"
     754                 :            :                      " storage. This makes the procedure unsafe when called"
     755                 :            :                      " recursively, or concurrently from multiple threads."
     756                 :            :                      " Consider using %<-frecursive%>, or increase the"
     757                 :            :                      " %<-fmax-stack-var-size=%> limit, or change the code to"
     758                 :            :                      " use an ALLOCATABLE array.",
     759                 :            :                      sym->name, &sym->declared_at);
     760                 :            : 
     761                 :        450 :       TREE_STATIC (decl) = 1;
     762                 :            : 
     763                 :            :       /* Because the size of this variable isn't known until now, we may have
     764                 :            :          greedily added an initializer to this variable (in build_init_assign)
     765                 :            :          even though the max-stack-var-size indicates the variable should be
     766                 :            :          static. Therefore we rip out the automatic initializer here and
     767                 :            :          replace it with a static one.  */
     768                 :        450 :       gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
     769                 :        450 :       gfc_code *prev = NULL;
     770                 :        450 :       gfc_code *code = sym->ns->code;
     771                 :        451 :       while (code && code->op == EXEC_INIT_ASSIGN)
     772                 :            :         {
     773                 :            :           /* Look for an initializer meant for this symbol.  */
     774                 :          9 :           if (code->expr1->symtree == st)
     775                 :            :             {
     776                 :          8 :               if (prev)
     777                 :          0 :                 prev->next = code->next;
     778                 :            :               else
     779                 :          8 :                 sym->ns->code = code->next;
     780                 :            : 
     781                 :            :               break;
     782                 :            :             }
     783                 :            : 
     784                 :          1 :           prev = code;
     785                 :          1 :           code = code->next;
     786                 :            :         }
     787                 :        450 :       if (code && code->op == EXEC_INIT_ASSIGN)
     788                 :            :         {
     789                 :            :           /* Keep the init expression for a static initializer.  */
     790                 :          8 :           sym->value = code->expr2;
     791                 :            :           /* Cleanup the defunct code object, without freeing the init expr.  */
     792                 :          8 :           code->expr2 = NULL;
     793                 :          8 :           gfc_free_statement (code);
     794                 :          8 :           free (code);
     795                 :            :         }
     796                 :            :     }
     797                 :            : 
     798                 :            :   /* Handle threadprivate variables.  */
     799                 :     121747 :   if (sym->attr.threadprivate
     800                 :     121747 :       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
     801                 :        146 :     set_decl_tls_model (decl, decl_default_tls_model (decl));
     802                 :            : 
     803                 :     121747 :   gfc_finish_decl_attrs (decl, &sym->attr);
     804                 :            : }
     805                 :            : 
     806                 :            : 
     807                 :            : /* Allocate the lang-specific part of a decl.  */
     808                 :            : 
     809                 :            : void
     810                 :      51994 : gfc_allocate_lang_decl (tree decl)
     811                 :            : {
     812                 :      51994 :   if (DECL_LANG_SPECIFIC (decl) == NULL)
     813                 :      49960 :     DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
     814                 :      51994 : }
     815                 :            : 
     816                 :            : /* Remember a symbol to generate initialization/cleanup code at function
     817                 :            :    entry/exit.  */
     818                 :            : 
     819                 :            : static void
     820                 :      52882 : gfc_defer_symbol_init (gfc_symbol * sym)
     821                 :            : {
     822                 :      52882 :   gfc_symbol *p;
     823                 :      52882 :   gfc_symbol *last;
     824                 :      52882 :   gfc_symbol *head;
     825                 :            : 
     826                 :            :   /* Don't add a symbol twice.  */
     827                 :      52882 :   if (sym->tlink)
     828                 :            :     return;
     829                 :            : 
     830                 :      49625 :   last = head = sym->ns->proc_name;
     831                 :      49625 :   p = last->tlink;
     832                 :            : 
     833                 :            :   /* Make sure that setup code for dummy variables which are used in the
     834                 :            :      setup of other variables is generated first.  */
     835                 :      49625 :   if (sym->attr.dummy)
     836                 :            :     {
     837                 :            :       /* Find the first dummy arg seen after us, or the first non-dummy arg.
     838                 :            :          This is a circular list, so don't go past the head.  */
     839                 :      11959 :       while (p != head
     840                 :      11959 :              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
     841                 :            :         {
     842                 :       2565 :           last = p;
     843                 :       2565 :           p = p->tlink;
     844                 :            :         }
     845                 :            :     }
     846                 :            :   /* Insert in between last and p.  */
     847                 :      49625 :   last->tlink = sym;
     848                 :      49625 :   sym->tlink = p;
     849                 :            : }
     850                 :            : 
     851                 :            : 
     852                 :            : /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
     853                 :            :    backend_decl for a module symbol, if it all ready exists.  If the
     854                 :            :    module gsymbol does not exist, it is created.  If the symbol does
     855                 :            :    not exist, it is added to the gsymbol namespace.  Returns true if
     856                 :            :    an existing backend_decl is found.  */
     857                 :            : 
     858                 :            : bool
     859                 :       9513 : gfc_get_module_backend_decl (gfc_symbol *sym)
     860                 :            : {
     861                 :       9513 :   gfc_gsymbol *gsym;
     862                 :       9513 :   gfc_symbol *s;
     863                 :       9513 :   gfc_symtree *st;
     864                 :            : 
     865                 :       9513 :   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
     866                 :            : 
     867                 :       9513 :   if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
     868                 :            :     {
     869                 :       9513 :       st = NULL;
     870                 :       9513 :       s = NULL;
     871                 :            : 
     872                 :            :       /* Check for a symbol with the same name. */
     873                 :       9513 :       if (gsym)
     874                 :       9374 :         gfc_find_symbol (sym->name, gsym->ns, 0, &s);
     875                 :            : 
     876                 :       9513 :       if (!s)
     877                 :            :         {
     878                 :        248 :           if (!gsym)
     879                 :            :             {
     880                 :        139 :               gsym = gfc_get_gsymbol (sym->module, false);
     881                 :        139 :               gsym->type = GSYM_MODULE;
     882                 :        139 :               gsym->ns = gfc_get_namespace (NULL, 0);
     883                 :            :             }
     884                 :            : 
     885                 :        248 :           st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
     886                 :        248 :           st->n.sym = sym;
     887                 :        248 :           sym->refs++;
     888                 :            :         }
     889                 :       9265 :       else if (gfc_fl_struct (sym->attr.flavor))
     890                 :            :         {
     891                 :       7595 :           if (s && s->attr.flavor == FL_PROCEDURE)
     892                 :            :             {
     893                 :       4143 :               gfc_interface *intr;
     894                 :       4143 :               gcc_assert (s->attr.generic);
     895                 :       4187 :               for (intr = s->generic; intr; intr = intr->next)
     896                 :       4187 :                 if (gfc_fl_struct (intr->sym->attr.flavor))
     897                 :            :                   {
     898                 :       4143 :                     s = intr->sym;
     899                 :       4143 :                     break;
     900                 :            :                   }
     901                 :            :             }
     902                 :            : 
     903                 :            :           /* Normally we can assume that s is a derived-type symbol since it
     904                 :            :              shares a name with the derived-type sym. However if sym is a
     905                 :            :              STRUCTURE, it may in fact share a name with any other basic type
     906                 :            :              variable. If s is in fact of derived type then we can continue
     907                 :            :              looking for a duplicate type declaration.  */
     908                 :       7595 :           if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED)
     909                 :            :             {
     910                 :          0 :               s = s->ts.u.derived;
     911                 :            :             }
     912                 :            : 
     913                 :       7595 :           if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
     914                 :            :             {
     915                 :         25 :               if (s->attr.flavor == FL_UNION)
     916                 :          0 :                 s->backend_decl = gfc_get_union_type (s);
     917                 :            :               else
     918                 :         25 :                 s->backend_decl = gfc_get_derived_type (s);
     919                 :            :             }
     920                 :       7595 :           gfc_copy_dt_decls_ifequal (s, sym, true);
     921                 :       7595 :           return true;
     922                 :            :         }
     923                 :       1670 :       else if (s->backend_decl)
     924                 :            :         {
     925                 :       1658 :           if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
     926                 :        327 :             gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
     927                 :            :                                        true);
     928                 :       1331 :           else if (sym->ts.type == BT_CHARACTER)
     929                 :        248 :             sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
     930                 :       1658 :           sym->backend_decl = s->backend_decl;
     931                 :       1658 :           return true;
     932                 :            :         }
     933                 :            :     }
     934                 :            :   return false;
     935                 :            : }
     936                 :            : 
     937                 :            : 
     938                 :            : /* Create an array index type variable with function scope.  */
     939                 :            : 
     940                 :            : static tree
     941                 :      30991 : create_index_var (const char * pfx, int nest)
     942                 :            : {
     943                 :      30991 :   tree decl;
     944                 :            : 
     945                 :      30991 :   decl = gfc_create_var_np (gfc_array_index_type, pfx);
     946                 :      30991 :   if (nest)
     947                 :         28 :     gfc_add_decl_to_parent_function (decl);
     948                 :            :   else
     949                 :      30963 :     gfc_add_decl_to_function (decl);
     950                 :      30991 :   return decl;
     951                 :            : }
     952                 :            : 
     953                 :            : 
     954                 :            : /* Create variables to hold all the non-constant bits of info for a
     955                 :            :    descriptorless array.  Remember these in the lang-specific part of the
     956                 :            :    type.  */
     957                 :            : 
     958                 :            : static void
     959                 :      40670 : gfc_build_qualified_array (tree decl, gfc_symbol * sym)
     960                 :            : {
     961                 :      40670 :   tree type;
     962                 :      40670 :   int dim;
     963                 :      40670 :   int nest;
     964                 :      40670 :   gfc_namespace* procns;
     965                 :      40670 :   symbol_attribute *array_attr;
     966                 :      40670 :   gfc_array_spec *as;
     967                 :      40670 :   bool is_classarray = IS_CLASS_ARRAY (sym);
     968                 :            : 
     969                 :      40670 :   type = TREE_TYPE (decl);
     970                 :      40670 :   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
     971                 :      40670 :   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
     972                 :            : 
     973                 :            :   /* We just use the descriptor, if there is one.  */
     974                 :      40670 :   if (GFC_DESCRIPTOR_TYPE_P (type))
     975                 :            :     return;
     976                 :            : 
     977                 :      32800 :   gcc_assert (GFC_ARRAY_TYPE_P (type));
     978                 :      32800 :   procns = gfc_find_proc_namespace (sym->ns);
     979                 :      65600 :   nest = (procns->proc_name->backend_decl != current_function_decl)
     980                 :      32800 :          && !sym->attr.contained;
     981                 :            : 
     982                 :        508 :   if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
     983                 :        258 :       && as->type != AS_ASSUMED_SHAPE
     984                 :      33048 :       && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
     985                 :            :     {
     986                 :        248 :       tree token;
     987                 :        248 :       tree token_type = build_qualified_type (pvoid_type_node,
     988                 :            :                                               TYPE_QUAL_RESTRICT);
     989                 :            : 
     990                 :        248 :       if (sym->module && (sym->attr.use_assoc
     991                 :         17 :                           || sym->ns->proc_name->attr.flavor == FL_MODULE))
     992                 :            :         {
     993                 :         17 :           tree token_name
     994                 :         17 :                 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
     995                 :            :                         IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym))));
     996                 :         17 :           token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name,
     997                 :            :                               token_type);
     998                 :         17 :           if (sym->attr.use_assoc)
     999                 :          3 :             DECL_EXTERNAL (token) = 1;
    1000                 :            :           else
    1001                 :         14 :             TREE_STATIC (token) = 1;
    1002                 :            : 
    1003                 :         17 :           TREE_PUBLIC (token) = 1;
    1004                 :            : 
    1005                 :         17 :           if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
    1006                 :            :             {
    1007                 :          0 :               DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
    1008                 :          0 :               DECL_VISIBILITY_SPECIFIED (token) = true;
    1009                 :            :             }
    1010                 :            :         }
    1011                 :            :       else
    1012                 :            :         {
    1013                 :        231 :           token = gfc_create_var_np (token_type, "caf_token");
    1014                 :        231 :           TREE_STATIC (token) = 1;
    1015                 :            :         }
    1016                 :            : 
    1017                 :        248 :       GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
    1018                 :        248 :       DECL_ARTIFICIAL (token) = 1;
    1019                 :        248 :       DECL_NONALIASED (token) = 1;
    1020                 :            : 
    1021                 :        248 :       if (sym->module && !sym->attr.use_assoc)
    1022                 :            :         {
    1023                 :         14 :           pushdecl (token);
    1024                 :         14 :           DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl;
    1025                 :         14 :           gfc_module_add_decl (cur_module, token);
    1026                 :            :         }
    1027                 :        234 :       else if (sym->attr.host_assoc
    1028                 :          3 :                && TREE_CODE (DECL_CONTEXT (current_function_decl))
    1029                 :        234 :                != TRANSLATION_UNIT_DECL)
    1030                 :          2 :         gfc_add_decl_to_parent_function (token);
    1031                 :            :       else
    1032                 :        232 :         gfc_add_decl_to_function (token);
    1033                 :            :     }
    1034                 :            : 
    1035                 :      77289 :   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
    1036                 :            :     {
    1037                 :      44489 :       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
    1038                 :            :         {
    1039                 :        259 :           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
    1040                 :        259 :           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
    1041                 :            :         }
    1042                 :            :       /* Don't try to use the unknown bound for assumed shape arrays.  */
    1043                 :      44489 :       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
    1044                 :      44489 :           && (as->type != AS_ASSUMED_SIZE
    1045                 :       1383 :               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
    1046                 :            :         {
    1047                 :      12701 :           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
    1048                 :      12701 :           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
    1049                 :            :         }
    1050                 :            : 
    1051                 :      44489 :       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
    1052                 :            :         {
    1053                 :       7469 :           GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
    1054                 :       7469 :           TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
    1055                 :            :         }
    1056                 :            :     }
    1057                 :        700 :   for (dim = GFC_TYPE_ARRAY_RANK (type);
    1058                 :      33500 :        dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
    1059                 :            :     {
    1060                 :        700 :       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
    1061                 :            :         {
    1062                 :         96 :           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
    1063                 :         96 :           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
    1064                 :            :         }
    1065                 :            :       /* Don't try to use the unknown ubound for the last coarray dimension.  */
    1066                 :        700 :       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
    1067                 :        700 :           && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
    1068                 :            :         {
    1069                 :         50 :           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
    1070                 :         50 :           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
    1071                 :            :         }
    1072                 :            :     }
    1073                 :      32800 :   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
    1074                 :            :     {
    1075                 :       5766 :       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
    1076                 :            :                                                         "offset");
    1077                 :       5766 :       TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
    1078                 :            : 
    1079                 :       5766 :       if (nest)
    1080                 :          8 :         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
    1081                 :            :       else
    1082                 :       5758 :         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
    1083                 :            :     }
    1084                 :            : 
    1085                 :      32800 :   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
    1086                 :      32800 :       && as->type != AS_ASSUMED_SIZE)
    1087                 :            :     {
    1088                 :      10416 :       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
    1089                 :      10416 :       TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
    1090                 :            :     }
    1091                 :            : 
    1092                 :      32800 :   if (POINTER_TYPE_P (type))
    1093                 :            :     {
    1094                 :      14077 :       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
    1095                 :      14077 :       gcc_assert (TYPE_LANG_SPECIFIC (type)
    1096                 :            :                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
    1097                 :      32800 :       type = TREE_TYPE (type);
    1098                 :            :     }
    1099                 :            : 
    1100                 :      32800 :   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
    1101                 :            :     {
    1102                 :      10416 :       tree size, range;
    1103                 :            : 
    1104                 :      10416 :       size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    1105                 :      10416 :                               GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
    1106                 :      10416 :       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    1107                 :            :                                 size);
    1108                 :      10416 :       TYPE_DOMAIN (type) = range;
    1109                 :      10416 :       layout_type (type);
    1110                 :            :     }
    1111                 :            : 
    1112                 :      59814 :   if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
    1113                 :      26795 :       && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
    1114                 :      58658 :       && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
    1115                 :            :     {
    1116                 :       4869 :       tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
    1117                 :            : 
    1118                 :       5255 :       for (dim = 0; dim < as->rank - 1; dim++)
    1119                 :            :         {
    1120                 :        386 :           gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
    1121                 :        386 :           gtype = TREE_TYPE (gtype);
    1122                 :            :         }
    1123                 :       4869 :       gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
    1124                 :       4869 :       if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
    1125                 :       4869 :         TYPE_NAME (type) = NULL_TREE;
    1126                 :            :     }
    1127                 :            : 
    1128                 :      32800 :   if (TYPE_NAME (type) == NULL_TREE)
    1129                 :            :     {
    1130                 :      10655 :       tree gtype = TREE_TYPE (type), rtype, type_decl;
    1131                 :            : 
    1132                 :      24873 :       for (dim = as->rank - 1; dim >= 0; dim--)
    1133                 :            :         {
    1134                 :      14218 :           tree lbound, ubound;
    1135                 :      14218 :           lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
    1136                 :      14218 :           ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
    1137                 :      14218 :           rtype = build_range_type (gfc_array_index_type, lbound, ubound);
    1138                 :      14218 :           gtype = build_array_type (gtype, rtype);
    1139                 :            :           /* Ensure the bound variables aren't optimized out at -O0.
    1140                 :            :              For -O1 and above they often will be optimized out, but
    1141                 :            :              can be tracked by VTA.  Also set DECL_NAMELESS, so that
    1142                 :            :              the artificial lbound.N or ubound.N DECL_NAME doesn't
    1143                 :            :              end up in debug info.  */
    1144                 :      14218 :           if (lbound
    1145                 :      14218 :               && VAR_P (lbound)
    1146                 :        259 :               && DECL_ARTIFICIAL (lbound)
    1147                 :      14477 :               && DECL_IGNORED_P (lbound))
    1148                 :            :             {
    1149                 :        259 :               if (DECL_NAME (lbound)
    1150                 :        259 :                   && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
    1151                 :            :                              "lbound") != 0)
    1152                 :        259 :                 DECL_NAMELESS (lbound) = 1;
    1153                 :        259 :               DECL_IGNORED_P (lbound) = 0;
    1154                 :            :             }
    1155                 :      14218 :           if (ubound
    1156                 :      13999 :               && VAR_P (ubound)
    1157                 :      12701 :               && DECL_ARTIFICIAL (ubound)
    1158                 :      26919 :               && DECL_IGNORED_P (ubound))
    1159                 :            :             {
    1160                 :      12701 :               if (DECL_NAME (ubound)
    1161                 :      12701 :                   && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
    1162                 :            :                              "ubound") != 0)
    1163                 :      12701 :                 DECL_NAMELESS (ubound) = 1;
    1164                 :      12701 :               DECL_IGNORED_P (ubound) = 0;
    1165                 :            :             }
    1166                 :            :         }
    1167                 :      10655 :       TYPE_NAME (type) = type_decl = build_decl (input_location,
    1168                 :            :                                                  TYPE_DECL, NULL, gtype);
    1169                 :      10655 :       DECL_ORIGINAL_TYPE (type_decl) = gtype;
    1170                 :            :     }
    1171                 :            : }
    1172                 :            : 
    1173                 :            : 
    1174                 :            : /* For some dummy arguments we don't use the actual argument directly.
    1175                 :            :    Instead we create a local decl and use that.  This allows us to perform
    1176                 :            :    initialization, and construct full type information.  */
    1177                 :            : 
    1178                 :            : static tree
    1179                 :      15575 : gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
    1180                 :            : {
    1181                 :      15575 :   tree decl;
    1182                 :      15575 :   tree type;
    1183                 :      15575 :   gfc_array_spec *as;
    1184                 :      15575 :   symbol_attribute *array_attr;
    1185                 :      15575 :   char *name;
    1186                 :      15575 :   gfc_packed packed;
    1187                 :      15575 :   int n;
    1188                 :      15575 :   bool known_size;
    1189                 :      15575 :   bool is_classarray = IS_CLASS_ARRAY (sym);
    1190                 :            : 
    1191                 :            :   /* Use the array as and attr.  */
    1192                 :      15575 :   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
    1193                 :      15575 :   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
    1194                 :            : 
    1195                 :            :   /* The dummy is returned for pointer, allocatable or assumed rank arrays.
    1196                 :            :      For class arrays the information if sym is an allocatable or pointer
    1197                 :            :      object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
    1198                 :            :      too many reasons to be of use here).  */
    1199                 :      15575 :   if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
    1200                 :      14312 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
    1201                 :      14312 :       || array_attr->allocatable
    1202                 :      11810 :       || (as && as->type == AS_ASSUMED_RANK))
    1203                 :            :     return dummy;
    1204                 :            : 
    1205                 :            :   /* Add to list of variables if not a fake result variable.
    1206                 :            :      These symbols are set on the symbol only, not on the class component.  */
    1207                 :      10018 :   if (sym->attr.result || sym->attr.dummy)
    1208                 :       9497 :     gfc_defer_symbol_init (sym);
    1209                 :            : 
    1210                 :            :   /* For a class array the array descriptor is in the _data component, while
    1211                 :            :      for a regular array the TREE_TYPE of the dummy is a pointer to the
    1212                 :            :      descriptor.  */
    1213                 :      19652 :   type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
    1214                 :            :                                   : TREE_TYPE (dummy));
    1215                 :            :   /* type now is the array descriptor w/o any indirection.  */
    1216                 :      20036 :   gcc_assert (TREE_CODE (dummy) == PARM_DECL
    1217                 :            :           && POINTER_TYPE_P (TREE_TYPE (dummy)));
    1218                 :            : 
    1219                 :            :   /* Do we know the element size?  */
    1220                 :       9510 :   known_size = sym->ts.type != BT_CHARACTER
    1221                 :      10018 :           || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
    1222                 :            : 
    1223                 :       9510 :   if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
    1224                 :            :     {
    1225                 :            :       /* For descriptorless arrays with known element size the actual
    1226                 :            :          argument is sufficient.  */
    1227                 :       5376 :       gfc_build_qualified_array (dummy, sym);
    1228                 :       5376 :       return dummy;
    1229                 :            :     }
    1230                 :            : 
    1231                 :       4642 :   if (GFC_DESCRIPTOR_TYPE_P (type))
    1232                 :            :     {
    1233                 :            :       /* Create a descriptorless array pointer.  */
    1234                 :       4423 :       packed = PACKED_NO;
    1235                 :            : 
    1236                 :            :       /* Even when -frepack-arrays is used, symbols with TARGET attribute
    1237                 :            :          are not repacked.  */
    1238                 :       4423 :       if (!flag_repack_arrays || sym->attr.target)
    1239                 :            :         {
    1240                 :       4421 :           if (as->type == AS_ASSUMED_SIZE)
    1241                 :          0 :             packed = PACKED_FULL;
    1242                 :            :         }
    1243                 :            :       else
    1244                 :            :         {
    1245                 :          2 :           if (as->type == AS_EXPLICIT)
    1246                 :            :             {
    1247                 :          3 :               packed = PACKED_FULL;
    1248                 :          3 :               for (n = 0; n < as->rank; n++)
    1249                 :            :                 {
    1250                 :          2 :                   if (!(as->upper[n]
    1251                 :          2 :                         && as->lower[n]
    1252                 :          2 :                         && as->upper[n]->expr_type == EXPR_CONSTANT
    1253                 :          2 :                         && as->lower[n]->expr_type == EXPR_CONSTANT))
    1254                 :            :                     {
    1255                 :            :                       packed = PACKED_PARTIAL;
    1256                 :            :                       break;
    1257                 :            :                     }
    1258                 :            :                 }
    1259                 :            :             }
    1260                 :            :           else
    1261                 :            :             packed = PACKED_PARTIAL;
    1262                 :            :         }
    1263                 :            : 
    1264                 :            :       /* For classarrays the element type is required, but
    1265                 :            :          gfc_typenode_for_spec () returns the array descriptor.  */
    1266                 :       4423 :       type = is_classarray ? gfc_get_element_type (type)
    1267                 :       4039 :                            : gfc_typenode_for_spec (&sym->ts);
    1268                 :       4423 :       type = gfc_get_nodesc_array_type (type, as, packed,
    1269                 :       4423 :                                         !sym->attr.target);
    1270                 :            :     }
    1271                 :            :   else
    1272                 :            :     {
    1273                 :            :       /* We now have an expression for the element size, so create a fully
    1274                 :            :          qualified type.  Reset sym->backend decl or this will just return the
    1275                 :            :          old type.  */
    1276                 :        219 :       DECL_ARTIFICIAL (sym->backend_decl) = 1;
    1277                 :        219 :       sym->backend_decl = NULL_TREE;
    1278                 :        219 :       type = gfc_sym_type (sym);
    1279                 :        219 :       packed = PACKED_FULL;
    1280                 :            :     }
    1281                 :            : 
    1282                 :       4642 :   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
    1283                 :       4642 :   decl = build_decl (input_location,
    1284                 :            :                      VAR_DECL, get_identifier (name), type);
    1285                 :            : 
    1286                 :       4642 :   DECL_ARTIFICIAL (decl) = 1;
    1287                 :       4642 :   DECL_NAMELESS (decl) = 1;
    1288                 :       4642 :   TREE_PUBLIC (decl) = 0;
    1289                 :       4642 :   TREE_STATIC (decl) = 0;
    1290                 :       4642 :   DECL_EXTERNAL (decl) = 0;
    1291                 :            : 
    1292                 :            :   /* Avoid uninitialized warnings for optional dummy arguments.  */
    1293                 :       4642 :   if (sym->attr.optional)
    1294                 :        441 :     TREE_NO_WARNING (decl) = 1;
    1295                 :            : 
    1296                 :            :   /* We should never get deferred shape arrays here.  We used to because of
    1297                 :            :      frontend bugs.  */
    1298                 :       4642 :   gcc_assert (as->type != AS_DEFERRED);
    1299                 :            : 
    1300                 :       4642 :   if (packed == PACKED_PARTIAL)
    1301                 :          1 :     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
    1302                 :       4641 :   else if (packed == PACKED_FULL)
    1303                 :        220 :     GFC_DECL_PACKED_ARRAY (decl) = 1;
    1304                 :            : 
    1305                 :       4642 :   gfc_build_qualified_array (decl, sym);
    1306                 :            : 
    1307                 :       4642 :   if (DECL_LANG_SPECIFIC (dummy))
    1308                 :        558 :     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
    1309                 :            :   else
    1310                 :       4084 :     gfc_allocate_lang_decl (decl);
    1311                 :            : 
    1312                 :       4642 :   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
    1313                 :            : 
    1314                 :       4642 :   if (sym->ns->proc_name->backend_decl == current_function_decl
    1315                 :        435 :       || sym->attr.contained)
    1316                 :       4634 :     gfc_add_decl_to_function (decl);
    1317                 :            :   else
    1318                 :          8 :     gfc_add_decl_to_parent_function (decl);
    1319                 :            : 
    1320                 :            :   return decl;
    1321                 :            : }
    1322                 :            : 
    1323                 :            : /* Return a constant or a variable to use as a string length.  Does not
    1324                 :            :    add the decl to the current scope.  */
    1325                 :            : 
    1326                 :            : static tree
    1327                 :      11958 : gfc_create_string_length (gfc_symbol * sym)
    1328                 :            : {
    1329                 :      11958 :   gcc_assert (sym->ts.u.cl);
    1330                 :      11958 :   gfc_conv_const_charlen (sym->ts.u.cl);
    1331                 :            : 
    1332                 :      11958 :   if (sym->ts.u.cl->backend_decl == NULL_TREE)
    1333                 :            :     {
    1334                 :       1940 :       tree length;
    1335                 :       1940 :       const char *name;
    1336                 :            : 
    1337                 :            :       /* The string length variable shall be in static memory if it is either
    1338                 :            :          explicitly SAVED, a module variable or with -fno-automatic. Only
    1339                 :            :          relevant is "len=:" - otherwise, it is either a constant length or
    1340                 :            :          it is an automatic variable.  */
    1341                 :       3880 :       bool static_length = sym->attr.save
    1342                 :       1885 :                            || sym->ns->proc_name->attr.flavor == FL_MODULE
    1343                 :       3825 :                            || (flag_max_stack_var_size == 0
    1344                 :          2 :                                && sym->ts.deferred && !sym->attr.dummy
    1345                 :          0 :                                && !sym->attr.result && !sym->attr.function);
    1346                 :            : 
    1347                 :            :       /* Also prefix the mangled name. We need to call GFC_PREFIX for static
    1348                 :            :          variables as some systems do not support the "." in the assembler name.
    1349                 :            :          For nonstatic variables, the "." does not appear in assembler.  */
    1350                 :       1885 :       if (static_length)
    1351                 :            :         {
    1352                 :         55 :           if (sym->module)
    1353                 :         18 :             name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
    1354                 :            :                                    sym->name);
    1355                 :            :           else
    1356                 :         37 :             name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
    1357                 :            :         }
    1358                 :       1885 :       else if (sym->module)
    1359                 :          0 :         name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
    1360                 :            :       else
    1361                 :       1885 :         name = gfc_get_string (".%s", sym->name);
    1362                 :            : 
    1363                 :       1940 :       length = build_decl (input_location,
    1364                 :            :                            VAR_DECL, get_identifier (name),
    1365                 :            :                            gfc_charlen_type_node);
    1366                 :       1940 :       DECL_ARTIFICIAL (length) = 1;
    1367                 :       1940 :       TREE_USED (length) = 1;
    1368                 :       1940 :       if (sym->ns->proc_name->tlink != NULL)
    1369                 :       1704 :         gfc_defer_symbol_init (sym);
    1370                 :            : 
    1371                 :       1940 :       sym->ts.u.cl->backend_decl = length;
    1372                 :            : 
    1373                 :       1940 :       if (static_length)
    1374                 :         55 :         TREE_STATIC (length) = 1;
    1375                 :            : 
    1376                 :       1940 :       if (sym->ns->proc_name->attr.flavor == FL_MODULE
    1377                 :         18 :           && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
    1378                 :         18 :         TREE_PUBLIC (length) = 1;
    1379                 :            :     }
    1380                 :            : 
    1381                 :      11958 :   gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
    1382                 :      11958 :   return sym->ts.u.cl->backend_decl;
    1383                 :            : }
    1384                 :            : 
    1385                 :            : /* If a variable is assigned a label, we add another two auxiliary
    1386                 :            :    variables.  */
    1387                 :            : 
    1388                 :            : static void
    1389                 :         97 : gfc_add_assign_aux_vars (gfc_symbol * sym)
    1390                 :            : {
    1391                 :         97 :   tree addr;
    1392                 :         97 :   tree length;
    1393                 :         97 :   tree decl;
    1394                 :            : 
    1395                 :         97 :   gcc_assert (sym->backend_decl);
    1396                 :            : 
    1397                 :         97 :   decl = sym->backend_decl;
    1398                 :         97 :   gfc_allocate_lang_decl (decl);
    1399                 :         97 :   GFC_DECL_ASSIGN (decl) = 1;
    1400                 :         97 :   length = build_decl (input_location,
    1401                 :            :                        VAR_DECL, create_tmp_var_name (sym->name),
    1402                 :            :                        gfc_charlen_type_node);
    1403                 :         97 :   addr = build_decl (input_location,
    1404                 :            :                      VAR_DECL, create_tmp_var_name (sym->name),
    1405                 :            :                      pvoid_type_node);
    1406                 :         97 :   gfc_finish_var_decl (length, sym);
    1407                 :         97 :   gfc_finish_var_decl (addr, sym);
    1408                 :            :   /*  STRING_LENGTH is also used as flag. Less than -1 means that
    1409                 :            :       ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
    1410                 :            :       target label's address. Otherwise, value is the length of a format string
    1411                 :            :       and ASSIGN_ADDR is its address.  */
    1412                 :         97 :   if (TREE_STATIC (length))
    1413                 :          1 :     DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
    1414                 :            :   else
    1415                 :         96 :     gfc_defer_symbol_init (sym);
    1416                 :            : 
    1417                 :         97 :   GFC_DECL_STRING_LEN (decl) = length;
    1418                 :         97 :   GFC_DECL_ASSIGN_ADDR (decl) = addr;
    1419                 :         97 : }
    1420                 :            : 
    1421                 :            : 
    1422                 :            : static tree
    1423                 :     196617 : add_attributes_to_decl (symbol_attribute sym_attr, tree list)
    1424                 :            : {
    1425                 :     196617 :   unsigned id;
    1426                 :     196617 :   tree attr;
    1427                 :            : 
    1428                 :    1376320 :   for (id = 0; id < EXT_ATTR_NUM; id++)
    1429                 :    1179700 :     if (sym_attr.ext_attr & (1 << id))
    1430                 :            :       {
    1431                 :          0 :         attr = build_tree_list (
    1432                 :          0 :                  get_identifier (ext_attr_list[id].middle_end_name),
    1433                 :            :                                  NULL_TREE);
    1434                 :          0 :         list = chainon (list, attr);
    1435                 :            :       }
    1436                 :            : 
    1437                 :     196617 :   tree clauses = NULL_TREE;
    1438                 :            : 
    1439                 :     196617 :   if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE)
    1440                 :            :     {
    1441                 :        179 :       omp_clause_code code;
    1442                 :        179 :       switch (sym_attr.oacc_routine_lop)
    1443                 :            :         {
    1444                 :            :         case OACC_ROUTINE_LOP_GANG:
    1445                 :            :           code = OMP_CLAUSE_GANG;
    1446                 :            :           break;
    1447                 :            :         case OACC_ROUTINE_LOP_WORKER:
    1448                 :            :           code = OMP_CLAUSE_WORKER;
    1449                 :            :           break;
    1450                 :            :         case OACC_ROUTINE_LOP_VECTOR:
    1451                 :            :           code = OMP_CLAUSE_VECTOR;
    1452                 :            :           break;
    1453                 :            :         case OACC_ROUTINE_LOP_SEQ:
    1454                 :            :           code = OMP_CLAUSE_SEQ;
    1455                 :            :           break;
    1456                 :          0 :         case OACC_ROUTINE_LOP_NONE:
    1457                 :          0 :         case OACC_ROUTINE_LOP_ERROR:
    1458                 :          0 :         default:
    1459                 :          0 :           gcc_unreachable ();
    1460                 :            :         }
    1461                 :        179 :       tree c = build_omp_clause (UNKNOWN_LOCATION, code);
    1462                 :        179 :       OMP_CLAUSE_CHAIN (c) = clauses;
    1463                 :        179 :       clauses = c;
    1464                 :            : 
    1465                 :        179 :       tree dims = oacc_build_routine_dims (clauses);
    1466                 :        179 :       list = oacc_replace_fn_attrib_attr (list, dims);
    1467                 :            :     }
    1468                 :            : 
    1469                 :     196617 :   if (sym_attr.omp_declare_target_link
    1470                 :     196617 :       || sym_attr.oacc_declare_link)
    1471                 :          4 :     list = tree_cons (get_identifier ("omp declare target link"),
    1472                 :            :                       NULL_TREE, list);
    1473                 :     196613 :   else if (sym_attr.omp_declare_target
    1474                 :            :            || sym_attr.oacc_declare_create
    1475                 :            :            || sym_attr.oacc_declare_copyin
    1476                 :            :            || sym_attr.oacc_declare_deviceptr
    1477                 :     196613 :            || sym_attr.oacc_declare_device_resident)
    1478                 :        354 :     list = tree_cons (get_identifier ("omp declare target"),
    1479                 :            :                       clauses, list);
    1480                 :            : 
    1481                 :     196617 :   return list;
    1482                 :            : }
    1483                 :            : 
    1484                 :            : 
    1485                 :            : static void build_function_decl (gfc_symbol * sym, bool global);
    1486                 :            : 
    1487                 :            : 
    1488                 :            : /* Return the decl for a gfc_symbol, create it if it doesn't already
    1489                 :            :    exist.  */
    1490                 :            : 
    1491                 :            : tree
    1492                 :    1065970 : gfc_get_symbol_decl (gfc_symbol * sym)
    1493                 :            : {
    1494                 :    1065970 :   tree decl;
    1495                 :    1065970 :   tree length = NULL_TREE;
    1496                 :    1065970 :   tree attributes;
    1497                 :    1065970 :   int byref;
    1498                 :    1065970 :   bool intrinsic_array_parameter = false;
    1499                 :    1065970 :   bool fun_or_res;
    1500                 :            : 
    1501                 :    1065970 :   gcc_assert (sym->attr.referenced
    1502                 :            :               || sym->attr.flavor == FL_PROCEDURE
    1503                 :            :               || sym->attr.use_assoc
    1504                 :            :               || sym->attr.used_in_submodule
    1505                 :            :               || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
    1506                 :            :               || (sym->module && sym->attr.if_source != IFSRC_DECL
    1507                 :            :                   && sym->backend_decl));
    1508                 :            : 
    1509                 :    1065970 :   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
    1510                 :     139924 :     byref = gfc_return_by_reference (sym->ns->proc_name);
    1511                 :            :   else
    1512                 :            :     byref = 0;
    1513                 :            : 
    1514                 :            :   /* Make sure that the vtab for the declared type is completed.  */
    1515                 :    1065970 :   if (sym->ts.type == BT_CLASS)
    1516                 :            :     {
    1517                 :      53137 :       gfc_component *c = CLASS_DATA (sym);
    1518                 :      53137 :       if (!c->ts.u.derived->backend_decl)
    1519                 :            :         {
    1520                 :       1768 :           gfc_find_derived_vtab (c->ts.u.derived);
    1521                 :       1768 :           gfc_get_derived_type (sym->ts.u.derived);
    1522                 :            :         }
    1523                 :            :     }
    1524                 :            : 
    1525                 :            :   /* PDT parameterized array components and string_lengths must have the
    1526                 :            :      'len' parameters substituted for the expressions appearing in the
    1527                 :            :      declaration of the entity and memory allocated/deallocated.  */
    1528                 :    1065970 :   if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
    1529                 :     200325 :       && sym->param_list != NULL
    1530                 :       2483 :       && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy))
    1531                 :       1612 :     gfc_defer_symbol_init (sym);
    1532                 :            : 
    1533                 :            :   /* Dummy PDT 'len' parameters should be checked when they are explicit.  */
    1534                 :    1065970 :   if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
    1535                 :     200325 :       && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    1536                 :       3324 :       && sym->param_list != NULL
    1537                 :        408 :       && sym->attr.dummy)
    1538                 :        180 :     gfc_defer_symbol_init (sym);
    1539                 :            : 
    1540                 :            :   /* All deferred character length procedures need to retain the backend
    1541                 :            :      decl, which is a pointer to the character length in the caller's
    1542                 :            :      namespace and to declare a local character length.  */
    1543                 :    1065970 :   if (!byref && sym->attr.function
    1544                 :      15856 :         && sym->ts.type == BT_CHARACTER
    1545                 :       1111 :         && sym->ts.deferred
    1546                 :        203 :         && sym->ts.u.cl->passed_length == NULL
    1547                 :          9 :         && sym->ts.u.cl->backend_decl
    1548                 :          0 :         && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
    1549                 :            :     {
    1550                 :          0 :       sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
    1551                 :          0 :       gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
    1552                 :          0 :       sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
    1553                 :            :     }
    1554                 :            : 
    1555                 :    1065970 :   if (is_CFI_desc (sym, NULL))
    1556                 :        347 :     gfc_defer_symbol_init (sym);
    1557                 :            : 
    1558                 :    1065970 :   fun_or_res = byref && (sym->attr.result
    1559                 :      13512 :                          || (sym->attr.function && sym->ts.deferred));
    1560                 :    1065970 :   if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
    1561                 :            :     {
    1562                 :            :       /* Return via extra parameter.  */
    1563                 :     214279 :       if (sym->attr.result && byref
    1564                 :       2707 :           && !sym->backend_decl)
    1565                 :            :         {
    1566                 :       1786 :           sym->backend_decl =
    1567                 :        893 :             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
    1568                 :            :           /* For entry master function skip over the __entry
    1569                 :            :              argument.  */
    1570                 :        893 :           if (sym->ns->proc_name->attr.entry_master)
    1571                 :         83 :             sym->backend_decl = DECL_CHAIN (sym->backend_decl);
    1572                 :            :         }
    1573                 :            : 
    1574                 :            :       /* Dummy variables should already have been created.  */
    1575                 :     214279 :       gcc_assert (sym->backend_decl);
    1576                 :            : 
    1577                 :            :       /* However, the string length of deferred arrays must be set.  */
    1578                 :     214279 :       if (sym->ts.type == BT_CHARACTER
    1579                 :      18526 :           && sym->ts.deferred
    1580                 :            :           && sym->attr.dimension
    1581                 :       1250 :           && sym->attr.allocatable)
    1582                 :         97 :         gfc_defer_symbol_init (sym);
    1583                 :            : 
    1584                 :     214279 :       if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
    1585                 :       6983 :         GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
    1586                 :            : 
    1587                 :            :       /* Create a character length variable.  */
    1588                 :     214279 :       if (sym->ts.type == BT_CHARACTER)
    1589                 :            :         {
    1590                 :            :           /* For a deferred dummy, make a new string length variable.  */
    1591                 :      18526 :           if (sym->ts.deferred
    1592                 :       1250 :                 &&
    1593                 :       1250 :              (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
    1594                 :          0 :             sym->ts.u.cl->backend_decl = NULL_TREE;
    1595                 :            : 
    1596                 :      18526 :           if (sym->ts.deferred && byref)
    1597                 :            :             {
    1598                 :            :               /* The string length of a deferred char array is stored in the
    1599                 :            :                  parameter at sym->ts.u.cl->backend_decl as a reference and
    1600                 :            :                  marked as a result.  Exempt this variable from generating a
    1601                 :            :                  temporary for it.  */
    1602                 :        467 :               if (sym->attr.result)
    1603                 :            :                 {
    1604                 :            :                   /* We need to insert a indirect ref for param decls.  */
    1605                 :        380 :                   if (sym->ts.u.cl->backend_decl
    1606                 :        380 :                       && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
    1607                 :            :                     {
    1608                 :          0 :                       sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
    1609                 :          0 :                       sym->ts.u.cl->backend_decl =
    1610                 :          0 :                         build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
    1611                 :            :                     }
    1612                 :            :                 }
    1613                 :            :               /* For all other parameters make sure, that they are copied so
    1614                 :            :                  that the value and any modifications are local to the routine
    1615                 :            :                  by generating a temporary variable.  */
    1616                 :         87 :               else if (sym->attr.function
    1617                 :         87 :                        && sym->ts.u.cl->passed_length == NULL
    1618                 :          0 :                        && sym->ts.u.cl->backend_decl)
    1619                 :            :                 {
    1620                 :          0 :                   sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
    1621                 :          0 :                   if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
    1622                 :          0 :                     sym->ts.u.cl->backend_decl
    1623                 :          0 :                         = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
    1624                 :            :                   else
    1625                 :          0 :                     sym->ts.u.cl->backend_decl = NULL_TREE;
    1626                 :            :                 }
    1627                 :            :             }
    1628                 :            : 
    1629                 :      18526 :           if (sym->ts.u.cl->backend_decl == NULL_TREE)
    1630                 :          2 :             length = gfc_create_string_length (sym);
    1631                 :            :           else
    1632                 :            :             length = sym->ts.u.cl->backend_decl;
    1633                 :      21013 :           if (VAR_P (length) && DECL_FILE_SCOPE_P (length))
    1634                 :            :             {
    1635                 :            :               /* Add the string length to the same context as the symbol.  */
    1636                 :        590 :               if (DECL_CONTEXT (length) == NULL_TREE)
    1637                 :            :                 {
    1638                 :        590 :                   if (sym->backend_decl == current_function_decl
    1639                 :        590 :                       || (DECL_CONTEXT (sym->backend_decl)
    1640                 :            :                           == current_function_decl))
    1641                 :        589 :                     gfc_add_decl_to_function (length);
    1642                 :            :                   else
    1643                 :          1 :                     gfc_add_decl_to_parent_function (length);
    1644                 :            :                 }
    1645                 :            : 
    1646                 :        611 :               gcc_assert (sym->backend_decl == current_function_decl
    1647                 :            :                           ? DECL_CONTEXT (length) == current_function_decl
    1648                 :            :                           : (DECL_CONTEXT (sym->backend_decl)
    1649                 :            :                              == DECL_CONTEXT (length)));
    1650                 :            : 
    1651                 :        590 :               gfc_defer_symbol_init (sym);
    1652                 :            :             }
    1653                 :            :         }
    1654                 :            : 
    1655                 :            :       /* Use a copy of the descriptor for dummy arrays.  */
    1656                 :     214279 :       if ((sym->attr.dimension || sym->attr.codimension)
    1657                 :      73725 :          && !TREE_USED (sym->backend_decl))
    1658                 :            :         {
    1659                 :      12874 :           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
    1660                 :            :           /* Prevent the dummy from being detected as unused if it is copied.  */
    1661                 :      12874 :           if (sym->backend_decl != NULL && decl != sym->backend_decl)
    1662                 :       3518 :             DECL_ARTIFICIAL (sym->backend_decl) = 1;
    1663                 :      12874 :           sym->backend_decl = decl;
    1664                 :            :         }
    1665                 :            : 
    1666                 :            :       /* Returning the descriptor for dummy class arrays is hazardous, because
    1667                 :            :          some caller is expecting an expression to apply the component refs to.
    1668                 :            :          Therefore the descriptor is only created and stored in
    1669                 :            :          sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR.  The caller is then
    1670                 :            :          responsible to extract it from there, when the descriptor is
    1671                 :            :          desired.  */
    1672                 :      18093 :       if (IS_CLASS_ARRAY (sym)
    1673                 :     219440 :           && (!DECL_LANG_SPECIFIC (sym->backend_decl)
    1674                 :       4039 :               || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
    1675                 :            :         {
    1676                 :       1986 :           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
    1677                 :            :           /* Prevent the dummy from being detected as unused if it is copied.  */
    1678                 :       1986 :           if (sym->backend_decl != NULL && decl != sym->backend_decl)
    1679                 :        384 :             DECL_ARTIFICIAL (sym->backend_decl) = 1;
    1680                 :       1986 :           sym->backend_decl = decl;
    1681                 :            :         }
    1682                 :            : 
    1683                 :     214279 :       TREE_USED (sym->backend_decl) = 1;
    1684                 :     214279 :       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
    1685                 :            :         {
    1686                 :          6 :           gfc_add_assign_aux_vars (sym);
    1687                 :            :         }
    1688                 :            : 
    1689                 :     214279 :       if (sym->ts.type == BT_CLASS && sym->backend_decl)
    1690                 :      18093 :         GFC_DECL_CLASS(sym->backend_decl) = 1;
    1691                 :            : 
    1692                 :     214279 :      return sym->backend_decl;
    1693                 :            :     }
    1694                 :            : 
    1695                 :     851693 :   if (sym->backend_decl)
    1696                 :            :     return sym->backend_decl;
    1697                 :            : 
    1698                 :            :   /* Special case for array-valued named constants from intrinsic
    1699                 :            :      procedures; those are inlined.  */
    1700                 :     132018 :   if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER
    1701                 :         68 :       && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
    1702                 :         68 :           || sym->from_intmod == INTMOD_ISO_C_BINDING))
    1703                 :          9 :     intrinsic_array_parameter = true;
    1704                 :            : 
    1705                 :            :   /* If use associated compilation, use the module
    1706                 :            :      declaration.  */
    1707                 :     132018 :   if ((sym->attr.flavor == FL_VARIABLE
    1708                 :      11042 :        || sym->attr.flavor == FL_PARAMETER)
    1709                 :     121795 :       && (sym->attr.use_assoc || sym->attr.used_in_submodule)
    1710                 :       1735 :       && !intrinsic_array_parameter
    1711                 :       1726 :       && sym->module
    1712                 :     133744 :       && gfc_get_module_backend_decl (sym))
    1713                 :            :     {
    1714                 :       1658 :       if (sym->ts.type == BT_CLASS && sym->backend_decl)
    1715                 :         25 :         GFC_DECL_CLASS(sym->backend_decl) = 1;
    1716                 :       1658 :       return sym->backend_decl;
    1717                 :            :     }
    1718                 :            : 
    1719                 :     130360 :   if (sym->attr.flavor == FL_PROCEDURE)
    1720                 :            :     {
    1721                 :            :       /* Catch functions. Only used for actual parameters,
    1722                 :            :          procedure pointers and procptr initialization targets.  */
    1723                 :      10223 :       if (sym->attr.use_assoc
    1724                 :            :           || sym->attr.used_in_submodule
    1725                 :      10223 :           || sym->attr.intrinsic
    1726                 :       8352 :           || sym->attr.if_source != IFSRC_DECL)
    1727                 :            :         {
    1728                 :       2592 :           decl = gfc_get_extern_function_decl (sym);
    1729                 :       2592 :           gfc_set_decl_location (decl, &sym->declared_at);
    1730                 :            :         }
    1731                 :            :       else
    1732                 :            :         {
    1733                 :       7631 :           if (!sym->backend_decl)
    1734                 :       7631 :             build_function_decl (sym, false);
    1735                 :       7631 :           decl = sym->backend_decl;
    1736                 :            :         }
    1737                 :      10223 :       return decl;
    1738                 :            :     }
    1739                 :            : 
    1740                 :     120137 :   if (sym->attr.intrinsic)
    1741                 :          0 :     gfc_internal_error ("intrinsic variable which isn't a procedure");
    1742                 :            : 
    1743                 :            :   /* Create string length decl first so that they can be used in the
    1744                 :            :      type declaration.  For associate names, the target character
    1745                 :            :      length is used. Set 'length' to a constant so that if the
    1746                 :            :      string length is a variable, it is not finished a second time.  */
    1747                 :     120137 :   if (sym->ts.type == BT_CHARACTER)
    1748                 :            :     {
    1749                 :      11706 :       if (sym->attr.associate_var
    1750                 :      11706 :           && sym->ts.deferred
    1751                 :        109 :           && sym->assoc && sym->assoc->target
    1752                 :        109 :           && ((sym->assoc->target->expr_type == EXPR_VARIABLE
    1753                 :         37 :                && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
    1754                 :         91 :               || sym->assoc->target->expr_type != EXPR_VARIABLE))
    1755                 :         90 :         sym->ts.u.cl->backend_decl = NULL_TREE;
    1756                 :            : 
    1757                 :      11706 :       if (sym->attr.associate_var
    1758                 :        522 :           && sym->ts.u.cl->backend_decl
    1759                 :         86 :           && (VAR_P (sym->ts.u.cl->backend_decl)
    1760                 :         62 :               || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL))
    1761                 :         30 :         length = gfc_index_zero_node;
    1762                 :            :       else
    1763                 :      11676 :         length = gfc_create_string_length (sym);
    1764                 :            :     }
    1765                 :            : 
    1766                 :            :   /* Create the decl for the variable.  */
    1767                 :     120137 :   decl = build_decl (gfc_get_location (&sym->declared_at),
    1768                 :            :                      VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
    1769                 :            : 
    1770                 :            :   /* Add attributes to variables.  Functions are handled elsewhere.  */
    1771                 :     120137 :   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
    1772                 :     120137 :   decl_attributes (&decl, attributes, 0);
    1773                 :            : 
    1774                 :            :   /* Symbols from modules should have their assembler names mangled.
    1775                 :            :      This is done here rather than in gfc_finish_var_decl because it
    1776                 :            :      is different for string length variables.  */
    1777                 :     120137 :   if (sym->module || sym->fn_result_spec)
    1778                 :            :     {
    1779                 :      11398 :       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
    1780                 :      11398 :       if (sym->attr.use_assoc && !intrinsic_array_parameter)
    1781                 :         68 :         DECL_IGNORED_P (decl) = 1;
    1782                 :            :     }
    1783                 :            : 
    1784                 :     120137 :   if (sym->attr.select_type_temporary)
    1785                 :            :     {
    1786                 :       2469 :       DECL_ARTIFICIAL (decl) = 1;
    1787                 :       2469 :       DECL_IGNORED_P (decl) = 1;
    1788                 :            :     }
    1789                 :            : 
    1790                 :     120137 :   if (sym->attr.dimension || sym->attr.codimension)
    1791                 :            :     {
    1792                 :            :       /* Create variables to hold the non-constant bits of array info.  */
    1793                 :      30652 :       gfc_build_qualified_array (decl, sym);
    1794                 :            : 
    1795                 :      30652 :       if (sym->attr.contiguous
    1796                 :      30652 :           || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
    1797                 :      27654 :         GFC_DECL_PACKED_ARRAY (decl) = 1;
    1798                 :            :     }
    1799                 :            : 
    1800                 :            :   /* Remember this variable for allocation/cleanup.  */
    1801                 :     120137 :   if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
    1802                 :      88007 :       || (sym->ts.type == BT_CLASS &&
    1803                 :       3000 :           (CLASS_DATA (sym)->attr.dimension
    1804                 :       3000 :            || CLASS_DATA (sym)->attr.allocatable))
    1805                 :      85936 :       || (sym->ts.type == BT_DERIVED
    1806                 :      19475 :           && (sym->ts.u.derived->attr.alloc_comp
    1807                 :      15231 :               || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
    1808                 :       3578 :                   && !sym->ns->proc_name->attr.is_main_program
    1809                 :      20651 :                   && gfc_is_finalizable (sym->ts.u.derived, NULL))))
    1810                 :            :       /* This applies a derived type default initializer.  */
    1811                 :     201817 :       || (sym->ts.type == BT_DERIVED
    1812                 :            :           && sym->attr.save == SAVE_NONE
    1813                 :            :           && !sym->attr.data
    1814                 :      15219 :           && !sym->attr.allocatable
    1815                 :       4467 :           && (sym->value && !sym->ns->proc_name->attr.is_main_program)
    1816                 :        295 :           && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
    1817                 :      38752 :     gfc_defer_symbol_init (sym);
    1818                 :            : 
    1819                 :     120137 :   if (sym->ts.type == BT_CHARACTER
    1820                 :            :       && sym->attr.allocatable
    1821                 :      11706 :       && !sym->attr.dimension
    1822                 :        589 :       && sym->ts.u.cl && sym->ts.u.cl->length
    1823                 :         76 :       && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
    1824                 :          7 :     gfc_defer_symbol_init (sym);
    1825                 :            : 
    1826                 :            :   /* Associate names can use the hidden string length variable
    1827                 :            :      of their associated target.  */
    1828                 :     120137 :   if (sym->ts.type == BT_CHARACTER
    1829                 :      11706 :       && TREE_CODE (length) != INTEGER_CST
    1830                 :       1680 :       && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
    1831                 :            :     {
    1832                 :       1680 :       length = fold_convert (gfc_charlen_type_node, length);
    1833                 :       1680 :       gfc_finish_var_decl (length, sym);
    1834                 :       1680 :       if (!sym->attr.associate_var
    1835                 :       1310 :           && TREE_CODE (length) == VAR_DECL
    1836                 :       1310 :           && sym->value && sym->value->expr_type != EXPR_NULL
    1837                 :          6 :           && sym->value->ts.u.cl->length)
    1838                 :            :         {
    1839                 :          6 :           gfc_expr *len = sym->value->ts.u.cl->length;
    1840                 :         12 :           DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
    1841                 :          6 :                                                         TREE_TYPE (length),
    1842                 :            :                                                         false, false, false);
    1843                 :          6 :           DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
    1844                 :          6 :                                                 DECL_INITIAL (length));
    1845                 :            :         }
    1846                 :            :       else
    1847                 :       1674 :         gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
    1848                 :            :     }
    1849                 :            : 
    1850                 :     120137 :   gfc_finish_var_decl (decl, sym);
    1851                 :            : 
    1852                 :     120137 :   if (sym->ts.type == BT_CHARACTER)
    1853                 :            :     /* Character variables need special handling.  */
    1854                 :      11706 :     gfc_allocate_lang_decl (decl);
    1855                 :            : 
    1856                 :     120137 :   if (sym->assoc && sym->attr.subref_array_pointer)
    1857                 :        108 :     sym->attr.pointer = 1;
    1858                 :            : 
    1859                 :     120137 :   if (sym->attr.pointer && sym->attr.dimension
    1860                 :       3088 :       && !sym->ts.deferred
    1861                 :       3583 :       && !(sym->attr.select_type_temporary
    1862                 :       3046 :            && !sym->attr.subref_array_pointer))
    1863                 :       2551 :     GFC_DECL_PTR_ARRAY_P (decl) = 1;
    1864                 :            : 
    1865                 :     120137 :   if (sym->ts.type == BT_CLASS)
    1866                 :       3000 :     GFC_DECL_CLASS(decl) = 1;
    1867                 :            : 
    1868                 :     120137 :   sym->backend_decl = decl;
    1869                 :            : 
    1870                 :     120137 :   if (sym->attr.assign)
    1871                 :         91 :     gfc_add_assign_aux_vars (sym);
    1872                 :            : 
    1873                 :     120137 :   if (intrinsic_array_parameter)
    1874                 :            :     {
    1875                 :          9 :       TREE_STATIC (decl) = 1;
    1876                 :          9 :       DECL_EXTERNAL (decl) = 0;
    1877                 :            :     }
    1878                 :            : 
    1879                 :     120137 :   if (TREE_STATIC (decl)
    1880                 :      25680 :       && !(sym->attr.use_assoc && !intrinsic_array_parameter)
    1881                 :      25680 :       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
    1882                 :       1542 :           || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
    1883                 :       1451 :           || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
    1884                 :      25563 :       && (flag_coarray != GFC_FCOARRAY_LIB
    1885                 :        352 :           || !sym->attr.codimension || sym->attr.allocatable)
    1886                 :      25345 :       && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
    1887                 :     145255 :       && !(sym->ts.type == BT_CLASS
    1888                 :       1179 :            && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
    1889                 :            :     {
    1890                 :            :       /* Add static initializer. For procedures, it is only needed if
    1891                 :            :          SAVE is specified otherwise they need to be reinitialized
    1892                 :            :          every time the procedure is entered. The TREE_STATIC is
    1893                 :            :          in this case due to -fmax-stack-var-size=.  */
    1894                 :            : 
    1895                 :      25100 :       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
    1896                 :      25100 :                                     TREE_TYPE (decl), sym->attr.dimension
    1897                 :      45956 :                                     || (sym->attr.codimension
    1898                 :      25100 :                                         && sym->attr.allocatable),
    1899                 :      25100 :                                     sym->attr.pointer || sym->attr.allocatable
    1900                 :      24496 :                                     || sym->ts.type == BT_CLASS,
    1901                 :      25100 :                                     sym->attr.proc_pointer);
    1902                 :            :     }
    1903                 :            : 
    1904                 :     120137 :   if (!TREE_STATIC (decl)
    1905                 :      94457 :       && POINTER_TYPE_P (TREE_TYPE (decl))
    1906                 :            :       && !sym->attr.pointer
    1907                 :            :       && !sym->attr.allocatable
    1908                 :      11872 :       && !sym->attr.proc_pointer
    1909                 :     126789 :       && !sym->attr.select_type_temporary)
    1910                 :       5448 :     DECL_BY_REFERENCE (decl) = 1;
    1911                 :            : 
    1912                 :     120137 :   if (sym->attr.associate_var)
    1913                 :       3605 :     GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
    1914                 :            : 
    1915                 :            :   /* We only longer mark __def_init as read-only if it actually has an
    1916                 :            :      initializer, it does not needlessly take up space in the
    1917                 :            :      read-only section and can go into the BSS instead, see PR 84487.
    1918                 :            :      Marking this as artificial means that OpenMP will treat this as
    1919                 :            :      predetermined shared.  */
    1920                 :            : 
    1921                 :     120137 :   bool def_init = gfc_str_startswith (sym->name, "__def_init");
    1922                 :            : 
    1923                 :     120137 :   if (sym->attr.vtab || def_init)
    1924                 :            :     {
    1925                 :      11436 :       DECL_ARTIFICIAL (decl) = 1;
    1926                 :      11436 :       if (def_init && sym->value)
    1927                 :       2516 :         TREE_READONLY (decl) = 1;
    1928                 :            :     }
    1929                 :            : 
    1930                 :     120137 :   return decl;
    1931                 :            : }
    1932                 :            : 
    1933                 :            : 
    1934                 :            : /* Substitute a temporary variable in place of the real one.  */
    1935                 :            : 
    1936                 :            : void
    1937                 :       5246 : gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
    1938                 :            : {
    1939                 :       5246 :   save->attr = sym->attr;
    1940                 :       5246 :   save->decl = sym->backend_decl;
    1941                 :            : 
    1942                 :       5246 :   gfc_clear_attr (&sym->attr);
    1943                 :       5246 :   sym->attr.referenced = 1;
    1944                 :       5246 :   sym->attr.flavor = FL_VARIABLE;
    1945                 :            : 
    1946                 :       5246 :   sym->backend_decl = decl;
    1947                 :       5246 : }
    1948                 :            : 
    1949                 :            : 
    1950                 :            : /* Restore the original variable.  */
    1951                 :            : 
    1952                 :            : void
    1953                 :       5246 : gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
    1954                 :            : {
    1955                 :       5246 :   sym->attr = save->attr;
    1956                 :       5246 :   sym->backend_decl = save->decl;
    1957                 :       5246 : }
    1958                 :            : 
    1959                 :            : 
    1960                 :            : /* Declare a procedure pointer.  */
    1961                 :            : 
    1962                 :            : static tree
    1963                 :        586 : get_proc_pointer_decl (gfc_symbol *sym)
    1964                 :            : {
    1965                 :        586 :   tree decl;
    1966                 :        586 :   tree attributes;
    1967                 :            : 
    1968                 :        586 :   if (sym->module || sym->fn_result_spec)
    1969                 :            :     {
    1970                 :        137 :       const char *name;
    1971                 :        137 :       gfc_gsymbol *gsym;
    1972                 :            : 
    1973                 :        137 :       name = mangled_identifier (sym);
    1974                 :        137 :       gsym = gfc_find_gsymbol (gfc_gsym_root, name);
    1975                 :        137 :       if (gsym != NULL)
    1976                 :            :         {
    1977                 :         74 :           gfc_symbol *s;
    1978                 :         74 :           gfc_find_symbol (sym->name, gsym->ns, 0, &s);
    1979                 :         74 :           if (s && s->backend_decl)
    1980                 :         74 :             return s->backend_decl;
    1981                 :            :         }
    1982                 :            :     }
    1983                 :            : 
    1984                 :        512 :   decl = sym->backend_decl;
    1985                 :        512 :   if (decl)
    1986                 :            :     return decl;
    1987                 :            : 
    1988                 :        512 :   decl = build_decl (input_location,
    1989                 :            :                      VAR_DECL, get_identifier (sym->name),
    1990                 :            :                      build_pointer_type (gfc_get_function_type (sym)));
    1991                 :            : 
    1992                 :        512 :   if (sym->module)
    1993                 :            :     {
    1994                 :            :       /* Apply name mangling.  */
    1995                 :         63 :       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
    1996                 :         63 :       if (sym->attr.use_assoc)
    1997                 :          0 :         DECL_IGNORED_P (decl) = 1;
    1998                 :            :     }
    1999                 :            : 
    2000                 :        512 :   if ((sym->ns->proc_name
    2001                 :        512 :       && sym->ns->proc_name->backend_decl == current_function_decl)
    2002                 :         69 :       || sym->attr.contained)
    2003                 :        443 :     gfc_add_decl_to_function (decl);
    2004                 :         69 :   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
    2005                 :          6 :     gfc_add_decl_to_parent_function (decl);
    2006                 :            : 
    2007                 :        512 :   sym->backend_decl = decl;
    2008                 :            : 
    2009                 :            :   /* If a variable is USE associated, it's always external.  */
    2010                 :        512 :   if (sym->attr.use_assoc)
    2011                 :            :     {
    2012                 :          0 :       DECL_EXTERNAL (decl) = 1;
    2013                 :          0 :       TREE_PUBLIC (decl) = 1;
    2014                 :            :     }
    2015                 :        512 :   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
    2016                 :            :     {
    2017                 :            :       /* This is the declaration of a module variable.  */
    2018                 :         63 :       TREE_PUBLIC (decl) = 1;
    2019                 :         63 :       if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
    2020                 :            :         {
    2021                 :          8 :           DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
    2022                 :          8 :           DECL_VISIBILITY_SPECIFIED (decl) = true;
    2023                 :            :         }
    2024                 :         63 :       TREE_STATIC (decl) = 1;
    2025                 :            :     }
    2026                 :            : 
    2027                 :        512 :   if (!sym->attr.use_assoc
    2028                 :        512 :         && (sym->attr.save != SAVE_NONE || sym->attr.data
    2029                 :        400 :               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
    2030                 :        112 :     TREE_STATIC (decl) = 1;
    2031                 :            : 
    2032                 :        512 :   if (TREE_STATIC (decl) && sym->value)
    2033                 :            :     {
    2034                 :            :       /* Add static initializer.  */
    2035                 :         73 :       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
    2036                 :         73 :                                                   TREE_TYPE (decl),
    2037                 :            :                                                   sym->attr.dimension,
    2038                 :         73 :                                                   false, true);
    2039                 :            :     }
    2040                 :            : 
    2041                 :            :   /* Handle threadprivate procedure pointers.  */
    2042                 :        512 :   if (sym->attr.threadprivate
    2043                 :        512 :       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
    2044                 :         12 :     set_decl_tls_model (decl, decl_default_tls_model (decl));
    2045                 :            : 
    2046                 :        512 :   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
    2047                 :        512 :   decl_attributes (&decl, attributes, 0);
    2048                 :            : 
    2049                 :        512 :   return decl;
    2050                 :            : }
    2051                 :            : 
    2052                 :            : 
    2053                 :            : /* Get a basic decl for an external function.  */
    2054                 :            : 
    2055                 :            : tree
    2056                 :      30571 : gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args)
    2057                 :            : {
    2058                 :      30571 :   tree type;
    2059                 :      30571 :   tree fndecl;
    2060                 :      30571 :   tree attributes;
    2061                 :      30571 :   gfc_expr e;
    2062                 :      30571 :   gfc_intrinsic_sym *isym;
    2063                 :      30571 :   gfc_expr argexpr;
    2064                 :      30571 :   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
    2065                 :      30571 :   tree name;
    2066                 :      30571 :   tree mangled_name;
    2067                 :      30571 :   gfc_gsymbol *gsym;
    2068                 :            : 
    2069                 :      30571 :   if (sym->backend_decl)
    2070                 :            :     return sym->backend_decl;
    2071                 :            : 
    2072                 :            :   /* We should never be creating external decls for alternate entry points.
    2073                 :            :      The procedure may be an alternate entry point, but we don't want/need
    2074                 :            :      to know that.  */
    2075                 :      30571 :   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
    2076                 :            : 
    2077                 :      30571 :   if (sym->attr.proc_pointer)
    2078                 :        586 :     return get_proc_pointer_decl (sym);
    2079                 :            : 
    2080                 :            :   /* See if this is an external procedure from the same file.  If so,
    2081                 :            :      return the backend_decl.  If we are looking at a BIND(C)
    2082                 :            :      procedure and the symbol is not BIND(C), or vice versa, we
    2083                 :            :      haven't found the right procedure.  */
    2084                 :            : 
    2085                 :      29985 :   if (sym->binding_label)
    2086                 :            :     {
    2087                 :        782 :       gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
    2088                 :        782 :       if (gsym && !gsym->bind_c)
    2089                 :            :         gsym = NULL;
    2090                 :            :     }
    2091                 :            :   else
    2092                 :            :     {
    2093                 :      29203 :       gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
    2094                 :      29203 :       if (gsym && gsym->bind_c)
    2095                 :            :         gsym = NULL;
    2096                 :            :     }
    2097                 :            : 
    2098                 :      29966 :   if (gsym && !gsym->defined)
    2099                 :            :     gsym = NULL;
    2100                 :            : 
    2101                 :            :   /* This can happen because of C binding.  */
    2102                 :      28180 :   if (gsym && gsym->ns && gsym->ns->proc_name
    2103                 :       6896 :       && gsym->ns->proc_name->attr.flavor == FL_MODULE)
    2104                 :        115 :     goto module_sym;
    2105                 :            : 
    2106                 :      29870 :   if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
    2107                 :      23025 :       && !sym->backend_decl
    2108                 :      23025 :       && gsym && gsym->ns
    2109                 :       6775 :       && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
    2110                 :       6775 :       && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
    2111                 :            :     {
    2112                 :       6775 :       if (!gsym->ns->proc_name->backend_decl)
    2113                 :            :         {
    2114                 :            :           /* By construction, the external function cannot be
    2115                 :            :              a contained procedure.  */
    2116                 :        709 :           locus old_loc;
    2117                 :            : 
    2118                 :        709 :           gfc_save_backend_locus (&old_loc);
    2119                 :        709 :           push_cfun (NULL);
    2120                 :            : 
    2121                 :        709 :           gfc_create_function_decl (gsym->ns, true);
    2122                 :            : 
    2123                 :        709 :           pop_cfun ();
    2124                 :        709 :           gfc_restore_backend_locus (&old_loc);
    2125                 :            :         }
    2126                 :            : 
    2127                 :            :       /* If the namespace has entries, the proc_name is the
    2128                 :            :          entry master.  Find the entry and use its backend_decl.
    2129                 :            :          otherwise, use the proc_name backend_decl.  */
    2130                 :       6775 :       if (gsym->ns->entries)
    2131                 :            :         {
    2132                 :            :           gfc_entry_list *entry = gsym->ns->entries;
    2133                 :            : 
    2134                 :       1303 :           for (; entry; entry = entry->next)
    2135                 :            :             {
    2136                 :       1303 :               if (strcmp (gsym->name, entry->sym->name) == 0)
    2137                 :            :                 {
    2138                 :        791 :                   sym->backend_decl = entry->sym->backend_decl;
    2139                 :        791 :                   break;
    2140                 :            :                 }
    2141                 :            :             }
    2142                 :            :         }
    2143                 :            :       else
    2144                 :       5984 :         sym->backend_decl = gsym->ns->proc_name->backend_decl;
    2145                 :            : 
    2146                 :       6775 :       if (sym->backend_decl)
    2147                 :            :         {
    2148                 :            :           /* Avoid problems of double deallocation of the backend declaration
    2149                 :            :              later in gfc_trans_use_stmts; cf. PR 45087.  */
    2150                 :       6775 :           if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
    2151                 :         76 :             sym->attr.use_assoc = 0;
    2152                 :            : 
    2153                 :       6775 :           return sym->backend_decl;
    2154                 :            :         }
    2155                 :            :     }
    2156                 :            : 
    2157                 :            :   /* See if this is a module procedure from the same file.  If so,
    2158                 :            :      return the backend_decl.  */
    2159                 :      23095 :   if (sym->module)
    2160                 :      10029 :     gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
    2161                 :            : 
    2162                 :      13066 : module_sym:
    2163                 :      23210 :   if (gsym && gsym->ns
    2164                 :       7484 :       && (gsym->type == GSYM_MODULE
    2165                 :        115 :           || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
    2166                 :            :     {
    2167                 :       7484 :       gfc_symbol *s;
    2168                 :            : 
    2169                 :       7484 :       s = NULL;
    2170                 :       7484 :       if (gsym->type == GSYM_MODULE)
    2171                 :       7369 :         gfc_find_symbol (sym->name, gsym->ns, 0, &s);
    2172                 :            :       else
    2173                 :        115 :         gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
    2174                 :            : 
    2175                 :       7484 :       if (s && s->backend_decl)
    2176                 :            :         {
    2177                 :       6277 :           if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
    2178                 :        575 :             gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
    2179                 :            :                                        true);
    2180                 :       5702 :           else if (sym->ts.type == BT_CHARACTER)
    2181                 :        287 :             sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
    2182                 :       6277 :           sym->backend_decl = s->backend_decl;
    2183                 :       6277 :           return sym->backend_decl;
    2184                 :            :         }
    2185                 :            :     }
    2186                 :            : 
    2187                 :      16933 :   if (sym->attr.intrinsic)
    2188                 :            :     {
    2189                 :            :       /* Call the resolution function to get the actual name.  This is
    2190                 :            :          a nasty hack which relies on the resolution functions only looking
    2191                 :            :          at the first argument.  We pass NULL for the second argument
    2192                 :            :          otherwise things like AINT get confused.  */
    2193                 :       1290 :       isym = gfc_find_function (sym->name);
    2194                 :       1290 :       gcc_assert (isym->resolve.f0 != NULL);
    2195                 :            : 
    2196                 :       1290 :       memset (&e, 0, sizeof (e));
    2197                 :       1290 :       e.expr_type = EXPR_FUNCTION;
    2198                 :            : 
    2199                 :       1290 :       memset (&argexpr, 0, sizeof (argexpr));
    2200                 :       1290 :       gcc_assert (isym->formal);
    2201                 :       1290 :       argexpr.ts = isym->formal->ts;
    2202                 :            : 
    2203                 :       1290 :       if (isym->formal->next == NULL)
    2204                 :       1042 :         isym->resolve.f1 (&e, &argexpr);
    2205                 :            :       else
    2206                 :            :         {
    2207                 :        248 :           if (isym->formal->next->next == NULL)
    2208                 :        232 :             isym->resolve.f2 (&e, &argexpr, NULL);
    2209                 :            :           else
    2210                 :            :             {
    2211                 :         16 :               if (isym->formal->next->next->next == NULL)
    2212                 :          0 :                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
    2213                 :            :               else
    2214                 :            :                 {
    2215                 :            :                   /* All specific intrinsics take less than 5 arguments.  */
    2216                 :         16 :                   gcc_assert (isym->formal->next->next->next->next == NULL);
    2217                 :         16 :                   if (isym->resolve.f1m == gfc_resolve_index_func)
    2218                 :            :                     {
    2219                 :            :                       /* gfc_resolve_index_func is special because it takes a
    2220                 :            :                          gfc_actual_arglist instead of individual arguments.  */
    2221                 :         16 :                       gfc_actual_arglist *a, *n;
    2222                 :         16 :                       int i;
    2223                 :         16 :                       a = gfc_get_actual_arglist();
    2224                 :         16 :                       n = a;
    2225                 :            : 
    2226                 :         80 :                       for (i = 0; i < 4; i++)
    2227                 :            :                         {
    2228                 :         64 :                           n->next = gfc_get_actual_arglist();
    2229                 :         64 :                           n = n->next;
    2230                 :            :                         }
    2231                 :            : 
    2232                 :         16 :                       a->expr = &argexpr;
    2233                 :         16 :                       isym->resolve.f1m (&e, a);
    2234                 :         16 :                       a->expr = NULL;
    2235                 :         16 :                       gfc_free_actual_arglist (a);
    2236                 :            :                     }
    2237                 :            :                   else
    2238                 :          0 :                     isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
    2239                 :            :                 }
    2240                 :            :             }
    2241                 :            :         }
    2242                 :            : 
    2243                 :       1290 :       if (flag_f2c
    2244                 :        438 :           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
    2245                 :        300 :               || e.ts.type == BT_COMPLEX))
    2246                 :            :         {
    2247                 :            :           /* Specific which needs a different implementation if f2c
    2248                 :            :              calling conventions are used.  */
    2249                 :        240 :           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
    2250                 :            :         }
    2251                 :            :       else
    2252                 :       1050 :         sprintf (s, "_gfortran_specific%s", e.value.function.name);
    2253                 :            : 
    2254                 :       1290 :       name = get_identifier (s);
    2255                 :       1290 :       mangled_name = name;
    2256                 :            :     }
    2257                 :            :   else
    2258                 :            :     {
    2259                 :      15643 :       name = gfc_sym_identifier (sym);
    2260                 :      15643 :       mangled_name = gfc_sym_mangled_function_id (sym);
    2261                 :            :     }
    2262                 :            : 
    2263                 :      16933 :   type = gfc_get_function_type (sym, actual_args);
    2264                 :      16933 :   fndecl = build_decl (input_location,
    2265                 :            :                        FUNCTION_DECL, name, type);
    2266                 :            : 
    2267                 :            :   /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
    2268                 :            :      TREE_PUBLIC specifies whether a function is globally addressable (i.e.
    2269                 :            :      the opposite of declaring a function as static in C).  */
    2270                 :      16933 :   DECL_EXTERNAL (fndecl) = 1;
    2271                 :      16933 :   TREE_PUBLIC (fndecl) = 1;
    2272                 :            : 
    2273                 :      16933 :   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
    2274                 :      16933 :   decl_attributes (&fndecl, attributes, 0);
    2275                 :            : 
    2276                 :      16933 :   gfc_set_decl_assembler_name (fndecl, mangled_name);
    2277                 :            : 
    2278                 :            :   /* Set the context of this decl.  */
    2279                 :      16933 :   if (0 && sym->ns && sym->ns->proc_name)
    2280                 :            :     {
    2281                 :            :       /* TODO: Add external decls to the appropriate scope.  */
    2282                 :            :       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
    2283                 :            :     }
    2284                 :            :   else
    2285                 :            :     {
    2286                 :            :       /* Global declaration, e.g. intrinsic subroutine.  */
    2287                 :      16933 :       DECL_CONTEXT (fndecl) = NULL_TREE;
    2288                 :            :     }
    2289                 :            : 
    2290                 :            :   /* Set attributes for PURE functions. A call to PURE function in the
    2291                 :            :      Fortran 95 sense is both pure and without side effects in the C
    2292                 :            :      sense.  */
    2293                 :      16933 :   if (sym->attr.pure || sym->attr.implicit_pure)
    2294                 :            :     {
    2295                 :       1929 :       if (sym->attr.function && !gfc_return_by_reference (sym))
    2296                 :       1837 :         DECL_PURE_P (fndecl) = 1;
    2297                 :            :       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
    2298                 :            :          parameters and don't use alternate returns (is this
    2299                 :            :          allowed?). In that case, calls to them are meaningless, and
    2300                 :            :          can be optimized away. See also in build_function_decl().  */
    2301                 :       1929 :       TREE_SIDE_EFFECTS (fndecl) = 0;
    2302                 :            :     }
    2303                 :            : 
    2304                 :            :   /* Mark non-returning functions.  */
    2305                 :      16933 :   if (sym->attr.noreturn)
    2306                 :        100 :       TREE_THIS_VOLATILE(fndecl) = 1;
    2307                 :            : 
    2308                 :      16933 :   sym->backend_decl = fndecl;
    2309                 :            : 
    2310                 :      16933 :   if (DECL_CONTEXT (fndecl) == NULL_TREE)
    2311                 :      16933 :     pushdecl_top_level (fndecl);
    2312                 :            : 
    2313                 :      16933 :   if (sym->formal_ns
    2314                 :      14723 :       && sym->formal_ns->proc_name == sym
    2315                 :      14723 :       && sym->formal_ns->omp_declare_simd)
    2316                 :         15 :     gfc_trans_omp_declare_simd (sym->formal_ns);
    2317                 :            : 
    2318                 :      16933 :   return fndecl;
    2319                 :            : }
    2320                 :            : 
    2321                 :            : 
    2322                 :            : /* Create a declaration for a procedure.  For external functions (in the C
    2323                 :            :    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
    2324                 :            :    a master function with alternate entry points.  */
    2325                 :            : 
    2326                 :            : static void
    2327                 :      66666 : build_function_decl (gfc_symbol * sym, bool global)
    2328                 :            : {
    2329                 :      66666 :   tree fndecl, type, attributes;
    2330                 :      66666 :   symbol_attribute attr;
    2331                 :      66666 :   tree result_decl;
    2332                 :      66666 :   gfc_formal_arglist *f;
    2333                 :            : 
    2334                 :     133332 :   bool module_procedure = sym->attr.module_procedure
    2335                 :        271 :                           && sym->ns
    2336                 :        271 :                           && sym->ns->proc_name
    2337                 :      66937 :                           && sym->ns->proc_name->attr.flavor == FL_MODULE;
    2338                 :            : 
    2339                 :      66666 :   gcc_assert (!sym->attr.external || module_procedure);
    2340                 :            : 
    2341                 :      66666 :   if (sym->backend_decl)
    2342                 :       7631 :     return;
    2343                 :            : 
    2344                 :            :   /* Set the line and filename.  sym->declared_at seems to point to the
    2345                 :            :      last statement for subroutines, but it'll do for now.  */
    2346                 :      59035 :   gfc_set_backend_locus (&sym->declared_at);
    2347                 :            : 
    2348                 :            :   /* Allow only one nesting level.  Allow public declarations.  */
    2349                 :      59035 :   gcc_assert (current_function_decl == NULL_TREE
    2350                 :            :               || DECL_FILE_SCOPE_P (current_function_decl)
    2351                 :            :               || (TREE_CODE (DECL_CONTEXT (current_function_decl))
    2352                 :            :                   == NAMESPACE_DECL));
    2353                 :            : 
    2354                 :      59035 :   type = gfc_get_function_type (sym);
    2355                 :      59035 :   fndecl = build_decl (input_location,
    2356                 :            :                        FUNCTION_DECL, gfc_sym_identifier (sym), type);
    2357                 :            : 
    2358                 :      59035 :   attr = sym->attr;
    2359                 :            : 
    2360                 :            :   /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
    2361                 :            :      TREE_PUBLIC specifies whether a function is globally addressable (i.e.
    2362                 :            :      the opposite of declaring a function as static in C).  */
    2363                 :      59035 :   DECL_EXTERNAL (fndecl) = 0;
    2364                 :            : 
    2365                 :      59035 :   if (sym->attr.access == ACCESS_UNKNOWN && sym->module
    2366                 :      15234 :       && (sym->ns->default_access == ACCESS_PRIVATE
    2367                 :      14216 :           || (sym->ns->default_access == ACCESS_UNKNOWN
    2368                 :      14204 :               && flag_module_private)))
    2369                 :       1018 :     sym->attr.access = ACCESS_PRIVATE;
    2370                 :            : 
    2371                 :      59035 :   if (!current_function_decl
    2372                 :      46822 :       && !sym->attr.entry_master && !sym->attr.is_main_program
    2373                 :      25062 :       && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
    2374                 :       1322 :           || sym->attr.public_used))
    2375                 :      24744 :     TREE_PUBLIC (fndecl) = 1;
    2376                 :            : 
    2377                 :      59035 :   if (sym->attr.referenced || sym->attr.entry_master)
    2378                 :      23847 :     TREE_USED (fndecl) = 1;
    2379                 :            : 
    2380                 :      59035 :   attributes = add_attributes_to_decl (attr, NULL_TREE);
    2381                 :      59035 :   decl_attributes (&fndecl, attributes, 0);
    2382                 :            : 
    2383                 :            :   /* Figure out the return type of the declared function, and build a
    2384                 :            :      RESULT_DECL for it.  If this is a subroutine with alternate
    2385                 :            :      returns, build a RESULT_DECL for it.  */
    2386                 :      59035 :   result_decl = NULL_TREE;
    2387                 :            :   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
    2388                 :      59035 :   if (attr.function)
    2389                 :            :     {
    2390                 :      11822 :       if (gfc_return_by_reference (sym))
    2391                 :       2604 :         type = void_type_node;
    2392                 :            :       else
    2393                 :            :         {
    2394                 :       9218 :           if (sym->result != sym)
    2395                 :       2604 :             result_decl = gfc_sym_identifier (sym->result);
    2396                 :            : 
    2397                 :       9218 :           type = TREE_TYPE (TREE_TYPE (fndecl));
    2398                 :            :         }
    2399                 :            :     }
    2400                 :            :   else
    2401                 :            :     {
    2402                 :            :       /* Look for alternate return placeholders.  */
    2403                 :      47213 :       int has_alternate_returns = 0;
    2404                 :      96330 :       for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    2405                 :            :         {
    2406                 :      49186 :           if (f->sym == NULL)
    2407                 :            :             {
    2408                 :            :               has_alternate_returns = 1;
    2409                 :            :               break;
    2410                 :            :             }
    2411                 :            :         }
    2412                 :            : 
    2413                 :      47213 :       if (has_alternate_returns)
    2414                 :         69 :         type = integer_type_node;
    2415                 :            :       else
    2416                 :      47144 :         type = void_type_node;
    2417                 :            :     }
    2418                 :            : 
    2419                 :      59035 :   result_decl = build_decl (input_location,
    2420                 :            :                             RESULT_DECL, result_decl, type);
    2421                 :      59035 :   DECL_ARTIFICIAL (result_decl) = 1;
    2422                 :      59035 :   DECL_IGNORED_P (result_decl) = 1;
    2423                 :      59035 :   DECL_CONTEXT (result_decl) = fndecl;
    2424                 :      59035 :   DECL_RESULT (fndecl) = result_decl;
    2425                 :            : 
    2426                 :            :   /* Don't call layout_decl for a RESULT_DECL.
    2427                 :            :      layout_decl (result_decl, 0);  */
    2428                 :            : 
    2429                 :            :   /* TREE_STATIC means the function body is defined here.  */
    2430                 :      59035 :   TREE_STATIC (fndecl) = 1;
    2431                 :            : 
    2432                 :            :   /* Set attributes for PURE functions. A call to a PURE function in the
    2433                 :            :      Fortran 95 sense is both pure and without side effects in the C
    2434                 :            :      sense.  */
    2435                 :      59035 :   if (attr.pure || attr.implicit_pure)
    2436                 :            :     {
    2437                 :            :       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
    2438                 :            :          including an alternate return. In that case it can also be
    2439                 :            :          marked as PURE. See also in gfc_get_extern_function_decl().  */
    2440                 :      12356 :       if (attr.function && !gfc_return_by_reference (sym))
    2441                 :       3506 :         DECL_PURE_P (fndecl) = 1;
    2442                 :      12356 :       TREE_SIDE_EFFECTS (fndecl) = 0;
    2443                 :            :     }
    2444                 :            : 
    2445                 :            : 
    2446                 :            :   /* Layout the function declaration and put it in the binding level
    2447                 :            :      of the current function.  */
    2448                 :            : 
    2449                 :      59035 :   if (global)
    2450                 :        709 :     pushdecl_top_level (fndecl);
    2451                 :            :   else
    2452                 :      58326 :     pushdecl (fndecl);
    2453                 :            : 
    2454                 :            :   /* Perform name mangling if this is a top level or module procedure.  */
    2455                 :      59035 :   if (current_function_decl == NULL_TREE)
    2456                 :      46822 :     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
    2457                 :            : 
    2458                 :      59035 :   sym->backend_decl = fndecl;
    2459                 :            : }
    2460                 :            : 
    2461                 :            : 
    2462                 :            : /* Create the DECL_ARGUMENTS for a procedure.  */
    2463                 :            : 
    2464                 :            : static void
    2465                 :      59035 : create_function_arglist (gfc_symbol * sym)
    2466                 :            : {
    2467                 :      59035 :   tree fndecl;
    2468                 :      59035 :   gfc_formal_arglist *f;
    2469                 :      59035 :   tree typelist, hidden_typelist;
    2470                 :      59035 :   tree arglist, hidden_arglist;
    2471                 :      59035 :   tree type;
    2472                 :      59035 :   tree parm;
    2473                 :            : 
    2474                 :      59035 :   fndecl = sym->backend_decl;
    2475                 :            : 
    2476                 :            :   /* Build formal argument list. Make sure that their TREE_CONTEXT is
    2477                 :            :      the new FUNCTION_DECL node.  */
    2478                 :      59035 :   arglist = NULL_TREE;
    2479                 :      59035 :   hidden_arglist = NULL_TREE;
    2480                 :      59035 :   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
    2481                 :            : 
    2482                 :      59035 :   if (sym->attr.entry_master)
    2483                 :            :     {
    2484                 :        574 :       type = TREE_VALUE (typelist);
    2485                 :        574 :       parm = build_decl (input_location,
    2486                 :            :                          PARM_DECL, get_identifier ("__entry"), type);
    2487                 :            : 
    2488                 :        574 :       DECL_CONTEXT (parm) = fndecl;
    2489                 :        574 :       DECL_ARG_TYPE (parm) = type;
    2490                 :        574 :       TREE_READONLY (parm) = 1;
    2491                 :        574 :       gfc_finish_decl (parm);
    2492                 :        574 :       DECL_ARTIFICIAL (parm) = 1;
    2493                 :            : 
    2494                 :        574 :       arglist = chainon (arglist, parm);
    2495                 :        574 :       typelist = TREE_CHAIN (typelist);
    2496                 :            :     }
    2497                 :            : 
    2498                 :      59035 :   if (gfc_return_by_reference (sym))
    2499                 :            :     {
    2500                 :       2604 :       tree type = TREE_VALUE (typelist), length = NULL;
    2501                 :            : 
    2502                 :       2604 :       if (sym->ts.type == BT_CHARACTER)
    2503                 :            :         {
    2504                 :            :           /* Length of character result.  */
    2505                 :       1372 :           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
    2506                 :            : 
    2507                 :       1372 :           length = build_decl (input_location,
    2508                 :            :                                PARM_DECL,
    2509                 :            :                                get_identifier (".__result"),
    2510                 :            :                                len_type);
    2511                 :       1372 :           if (POINTER_TYPE_P (len_type))
    2512                 :            :             {
    2513                 :        186 :               sym->ts.u.cl->passed_length = length;
    2514                 :        186 :               TREE_USED (length) = 1;
    2515                 :            :             }
    2516                 :       1186 :           else if (!sym->ts.u.cl->length)
    2517                 :            :             {
    2518                 :        156 :               sym->ts.u.cl->backend_decl = length;
    2519                 :        156 :               TREE_USED (length) = 1;
    2520                 :            :             }
    2521                 :       1372 :           gcc_assert (TREE_CODE (length) == PARM_DECL);
    2522                 :       1372 :           DECL_CONTEXT (length) = fndecl;
    2523                 :       1372 :           DECL_ARG_TYPE (length) = len_type;
    2524                 :       1372 :           TREE_READONLY (length) = 1;
    2525                 :       1372 :           DECL_ARTIFICIAL (length) = 1;
    2526                 :       1372 :           gfc_finish_decl (length);
    2527                 :       1372 :           if (sym->ts.u.cl->backend_decl == NULL
    2528                 :        549 :               || sym->ts.u.cl->backend_decl == length)
    2529                 :            :             {
    2530                 :        979 :               gfc_symbol *arg;
    2531                 :        979 :               tree backend_decl;
    2532                 :            : 
    2533                 :        979 :               if (sym->ts.u.cl->backend_decl == NULL)
    2534                 :            :                 {
    2535                 :        823 :                   tree len = build_decl (input_location,
    2536                 :            :                                          VAR_DECL,
    2537                 :            :                                          get_identifier ("..__result"),
    2538                 :            :                                          gfc_charlen_type_node);
    2539                 :        823 :                   DECL_ARTIFICIAL (len) = 1;
    2540                 :        823 :                   TREE_USED (len) = 1;
    2541                 :        823 :                   sym->ts.u.cl->backend_decl = len;
    2542                 :            :                 }
    2543                 :            : 
    2544                 :            :               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
    2545                 :        979 :               arg = sym->result ? sym->result : sym;
    2546                 :        979 :               backend_decl = arg->backend_decl;
    2547                 :            :               /* Temporary clear it, so that gfc_sym_type creates complete
    2548                 :            :                  type.  */
    2549                 :        979 :               arg->backend_decl = NULL;
    2550                 :        979 :               type = gfc_sym_type (arg);
    2551                 :        979 :               arg->backend_decl = backend_decl;
    2552                 :        979 :               type = build_reference_type (type);
    2553                 :            :             }
    2554                 :            :         }
    2555                 :            : 
    2556                 :       2604 :       parm = build_decl (input_location,
    2557                 :            :                          PARM_DECL, get_identifier ("__result"), type);
    2558                 :            : 
    2559                 :       2604 :       DECL_CONTEXT (parm) = fndecl;
    2560                 :       2604 :       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
    2561                 :       2604 :       TREE_READONLY (parm) = 1;
    2562                 :       2604 :       DECL_ARTIFICIAL (parm) = 1;
    2563                 :       2604 :       gfc_finish_decl (parm);
    2564                 :            : 
    2565                 :       2604 :       arglist = chainon (arglist, parm);
    2566                 :       2604 :       typelist = TREE_CHAIN (typelist);
    2567                 :            : 
    2568                 :       2604 :       if (sym->ts.type == BT_CHARACTER)
    2569                 :            :         {
    2570                 :       1372 :           gfc_allocate_lang_decl (parm);
    2571                 :       1372 :           arglist = chainon (arglist, length);
    2572                 :       1372 :           typelist = TREE_CHAIN (typelist);
    2573                 :            :         }
    2574                 :            :     }
    2575                 :            : 
    2576                 :      59035 :   hidden_typelist = typelist;
    2577                 :     124208 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    2578                 :      65173 :     if (f->sym != NULL)      /* Ignore alternate returns.  */
    2579                 :      65074 :       hidden_typelist = TREE_CHAIN (hidden_typelist);
    2580                 :            : 
    2581                 :     124208 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    2582                 :            :     {
    2583                 :      65173 :       char name[GFC_MAX_SYMBOL_LEN + 2];
    2584                 :            : 
    2585                 :            :       /* Ignore alternate returns.  */
    2586                 :      65173 :       if (f->sym == NULL)
    2587                 :         99 :         continue;
    2588                 :            : 
    2589                 :      65074 :       type = TREE_VALUE (typelist);
    2590                 :            : 
    2591                 :      65074 :       if (f->sym->ts.type == BT_CHARACTER
    2592                 :       5411 :           && (!sym->attr.is_bind_c || sym->attr.entry_master))
    2593                 :            :         {
    2594                 :       5336 :           tree len_type = TREE_VALUE (hidden_typelist);
    2595                 :       5336 :           tree length = NULL_TREE;
    2596                 :       5336 :           if (!f->sym->ts.deferred)
    2597                 :       5183 :             gcc_assert (len_type == gfc_charlen_type_node);
    2598                 :            :           else
    2599                 :        153 :             gcc_assert (POINTER_TYPE_P (len_type));
    2600                 :            : 
    2601                 :       5336 :           strcpy (&name[1], f->sym->name);
    2602                 :       5336 :           name[0] = '_';
    2603                 :       5336 :           length = build_decl (input_location,
    2604                 :            :                                PARM_DECL, get_identifier (name), len_type);
    2605                 :            : 
    2606                 :       5336 :           hidden_arglist = chainon (hidden_arglist, length);
    2607                 :       5336 :           DECL_CONTEXT (length) = fndecl;
    2608                 :       5336 :           DECL_ARTIFICIAL (length) = 1;
    2609                 :       5336 :           DECL_ARG_TYPE (length) = len_type;
    2610                 :       5336 :           TREE_READONLY (length) = 1;
    2611                 :       5336 :           gfc_finish_decl (length);
    2612                 :            : 
    2613                 :            :           /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
    2614                 :            :              to tail calls being disabled.  Only do that if we
    2615                 :            :              potentially have broken callers.  */
    2616                 :       5336 :           if (flag_tail_call_workaround
    2617                 :       5336 :               && f->sym->ts.u.cl
    2618                 :       5086 :               && f->sym->ts.u.cl->length
    2619                 :       1622 :               && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
    2620                 :       1363 :               && (flag_tail_call_workaround == 2
    2621                 :       1363 :                   || f->sym->ns->implicit_interface_calls))
    2622                 :         94 :             DECL_HIDDEN_STRING_LENGTH (length) = 1;
    2623                 :            : 
    2624                 :            :           /* Remember the passed value.  */
    2625                 :       5336 :           if (!f->sym->ts.u.cl ||  f->sym->ts.u.cl->passed_length)
    2626                 :            :             {
    2627                 :            :               /* This can happen if the same type is used for multiple
    2628                 :            :                  arguments. We need to copy cl as otherwise
    2629                 :            :                  cl->passed_length gets overwritten.  */
    2630                 :        535 :               f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
    2631                 :            :             }
    2632                 :       5336 :           f->sym->ts.u.cl->passed_length = length;
    2633                 :            : 
    2634                 :            :           /* Use the passed value for assumed length variables.  */
    2635                 :       5336 :           if (!f->sym->ts.u.cl->length)
    2636                 :            :             {
    2637                 :       3714 :               TREE_USED (length) = 1;
    2638                 :       3714 :               gcc_assert (!f->sym->ts.u.cl->backend_decl);
    2639                 :       3714 :               f->sym->ts.u.cl->backend_decl = length;
    2640                 :            :             }
    2641                 :            : 
    2642                 :       5336 :           hidden_typelist = TREE_CHAIN (hidden_typelist);
    2643                 :            : 
    2644                 :       5336 :           if (f->sym->ts.u.cl->backend_decl == NULL
    2645                 :       5056 :               || f->sym->ts.u.cl->backend_decl == length)
    2646                 :            :             {
    2647                 :       3994 :               if (POINTER_TYPE_P (len_type))
    2648                 :        153 :                 f->sym->ts.u.cl->backend_decl
    2649                 :        153 :                   = build_fold_indirect_ref_loc (input_location, length);
    2650                 :       3841 :               else if (f->sym->ts.u.cl->backend_decl == NULL)
    2651                 :        280 :                 gfc_create_string_length (f->sym);
    2652                 :            : 
    2653                 :            :               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
    2654                 :       3994 :               if (f->sym->attr.flavor == FL_PROCEDURE)
    2655                 :         12 :                 type = build_pointer_type (gfc_get_function_type (f->sym));
    2656                 :            :               else
    2657                 :       3982 :                 type = gfc_sym_type (f->sym);
    2658                 :            :             }
    2659                 :            :         }
    2660                 :            :       /* For noncharacter scalar intrinsic types, VALUE passes the value,
    2661                 :            :          hence, the optional status cannot be transferred via a NULL pointer.
    2662                 :            :          Thus, we will use a hidden argument in that case.  */
    2663                 :      59738 :       else if (f->sym->attr.optional && f->sym->attr.value
    2664                 :      59738 :                && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
    2665                 :        156 :                && !gfc_bt_struct (f->sym->ts.type))
    2666                 :            :         {
    2667                 :        156 :           tree tmp;
    2668                 :        156 :           strcpy (&name[1], f->sym->name);
    2669                 :        156 :           name[0] = '_';
    2670                 :        156 :           tmp = build_decl (input_location,
    2671                 :            :                             PARM_DECL, get_identifier (name),
    2672                 :            :                             boolean_type_node);
    2673                 :            : 
    2674                 :        156 :           hidden_arglist = chainon (hidden_arglist, tmp);
    2675                 :        156 :           DECL_CONTEXT (tmp) = fndecl;
    2676                 :        156 :           DECL_ARTIFICIAL (tmp) = 1;
    2677                 :        156 :           DECL_ARG_TYPE (tmp) = boolean_type_node;
    2678                 :        156 :           TREE_READONLY (tmp) = 1;
    2679                 :        156 :           gfc_finish_decl (tmp);
    2680                 :            : 
    2681                 :        156 :           hidden_typelist = TREE_CHAIN (hidden_typelist);
    2682                 :            :         }
    2683                 :            : 
    2684                 :            :       /* For non-constant length array arguments, make sure they use
    2685                 :            :          a different type node from TYPE_ARG_TYPES type.  */
    2686                 :      65074 :       if (f->sym->attr.dimension
    2687                 :      14231 :           && type == TREE_VALUE (typelist)
    2688                 :      13670 :           && TREE_CODE (type) == POINTER_TYPE
    2689                 :       7743 :           && GFC_ARRAY_TYPE_P (type)
    2690                 :       6635 :           && f->sym->as->type != AS_ASSUMED_SIZE
    2691                 :      70282 :           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
    2692                 :            :         {
    2693                 :       2328 :           if (f->sym->attr.flavor == FL_PROCEDURE)
    2694                 :          0 :             type = build_pointer_type (gfc_get_function_type (f->sym));
    2695                 :            :           else
    2696                 :       2328 :             type = gfc_sym_type (f->sym);
    2697                 :            :         }
    2698                 :            : 
    2699                 :      65074 :       if (f->sym->attr.proc_pointer)
    2700                 :        111 :         type = build_pointer_type (type);
    2701                 :            : 
    2702                 :      65074 :       if (f->sym->attr.volatile_)
    2703                 :          1 :         type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
    2704                 :            : 
    2705                 :            :       /* Build the argument declaration.  */
    2706                 :      65074 :       parm = build_decl (input_location,
    2707                 :            :                          PARM_DECL, gfc_sym_identifier (f->sym), type);
    2708                 :            : 
    2709                 :      65074 :       if (f->sym->attr.volatile_)
    2710                 :            :         {
    2711                 :          1 :           TREE_THIS_VOLATILE (parm) = 1;
    2712                 :          1 :           TREE_SIDE_EFFECTS (parm) = 1;
    2713                 :            :         }
    2714                 :            : 
    2715                 :            :       /* Fill in arg stuff.  */
    2716                 :      65074 :       DECL_CONTEXT (parm) = fndecl;
    2717                 :      65074 :       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
    2718                 :            :       /* All implementation args except for VALUE are read-only.  */
    2719                 :      65074 :       if (!f->sym->attr.value)
    2720                 :      60572 :         TREE_READONLY (parm) = 1;
    2721                 :      65074 :       if (POINTER_TYPE_P (type)
    2722                 :      60971 :           && (!f->sym->attr.proc_pointer
    2723                 :      60860 :               && f->sym->attr.flavor != FL_PROCEDURE))
    2724                 :      60150 :         DECL_BY_REFERENCE (parm) = 1;
    2725                 :      65074 :       if (f->sym->attr.optional)
    2726                 :            :         {
    2727                 :       3439 :           gfc_allocate_lang_decl (parm);
    2728                 :       3439 :           GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1;
    2729                 :            :         }
    2730                 :            : 
    2731                 :      65074 :       gfc_finish_decl (parm);
    2732                 :      65074 :       gfc_finish_decl_attrs (parm, &f->sym->attr);
    2733                 :            : 
    2734                 :      65074 :       f->sym->backend_decl = parm;
    2735                 :            : 
    2736                 :            :       /* Coarrays which are descriptorless or assumed-shape pass with
    2737                 :            :          -fcoarray=lib the token and the offset as hidden arguments.  */
    2738                 :      65074 :       if (flag_coarray == GFC_FCOARRAY_LIB
    2739                 :        209 :           && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
    2740                 :        197 :                && !f->sym->attr.allocatable)
    2741                 :        166 :               || (f->sym->ts.type == BT_CLASS
    2742                 :         12 :                   && CLASS_DATA (f->sym)->attr.codimension
    2743                 :         12 :                   && !CLASS_DATA (f->sym)->attr.allocatable)))
    2744                 :            :         {
    2745                 :         52 :           tree caf_type;
    2746                 :         52 :           tree token;
    2747                 :         52 :           tree offset;
    2748                 :            : 
    2749                 :         52 :           gcc_assert (f->sym->backend_decl != NULL_TREE
    2750                 :            :                       && !sym->attr.is_bind_c);
    2751                 :        104 :           caf_type = f->sym->ts.type == BT_CLASS
    2752                 :         52 :                      ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
    2753                 :         43 :                      : TREE_TYPE (f->sym->backend_decl);
    2754                 :            : 
    2755                 :         52 :           token = build_decl (input_location, PARM_DECL,
    2756                 :            :                               create_tmp_var_name ("caf_token"),
    2757                 :            :                               build_qualified_type (pvoid_type_node,
    2758                 :            :                                                     TYPE_QUAL_RESTRICT));
    2759                 :         52 :           if ((f->sym->ts.type != BT_CLASS
    2760                 :         43 :                && f->sym->as->type != AS_DEFERRED)
    2761                 :          9 :               || (f->sym->ts.type == BT_CLASS
    2762                 :          9 :                   && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
    2763                 :            :             {
    2764                 :         52 :               gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
    2765                 :            :                           || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
    2766                 :         52 :               if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
    2767                 :         47 :                 gfc_allocate_lang_decl (f->sym->backend_decl);
    2768                 :         52 :               GFC_DECL_TOKEN (f->sym->backend_decl) = token;
    2769                 :            :             }
    2770                 :            :           else
    2771                 :            :             {
    2772                 :          0 :               gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
    2773                 :          0 :               GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
    2774                 :            :             }
    2775                 :            : 
    2776                 :         52 :           DECL_CONTEXT (token) = fndecl;
    2777                 :         52 :           DECL_ARTIFICIAL (token) = 1;
    2778                 :         52 :           DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
    2779                 :         52 :           TREE_READONLY (token) = 1;
    2780                 :         52 :           hidden_arglist = chainon (hidden_arglist, token);
    2781                 :         52 :           gfc_finish_decl (token);
    2782                 :            : 
    2783                 :         52 :           offset = build_decl (input_location, PARM_DECL,
    2784                 :            :                                create_tmp_var_name ("caf_offset"),
    2785                 :            :                                gfc_array_index_type);
    2786                 :            : 
    2787                 :         52 :           if ((f->sym->ts.type != BT_CLASS
    2788                 :         43 :                && f->sym->as->type != AS_DEFERRED)
    2789                 :          9 :               || (f->sym->ts.type == BT_CLASS
    2790                 :          9 :                   && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
    2791                 :            :             {
    2792                 :         52 :               gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
    2793                 :            :                                                == NULL_TREE);
    2794                 :         52 :               GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
    2795                 :            :             }
    2796                 :            :           else
    2797                 :            :             {
    2798                 :          0 :               gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
    2799                 :          0 :               GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
    2800                 :            :             }
    2801                 :         52 :           DECL_CONTEXT (offset) = fndecl;
    2802                 :         52 :           DECL_ARTIFICIAL (offset) = 1;
    2803                 :         52 :           DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
    2804                 :         52 :           TREE_READONLY (offset) = 1;
    2805                 :         52 :           hidden_arglist = chainon (hidden_arglist, offset);
    2806                 :         52 :           gfc_finish_decl (offset);
    2807                 :            :         }
    2808                 :            : 
    2809                 :      65074 :       arglist = chainon (arglist, parm);
    2810                 :      65074 :       typelist = TREE_CHAIN (typelist);
    2811                 :            :     }
    2812                 :            : 
    2813                 :            :   /* Add the hidden string length parameters, unless the procedure
    2814                 :            :      is bind(C).  */
    2815                 :      59035 :   if (!sym->attr.is_bind_c)
    2816                 :      58347 :     arglist = chainon (arglist, hidden_arglist);
    2817                 :            : 
    2818                 :     118070 :   gcc_assert (hidden_typelist == NULL_TREE
    2819                 :            :               || TREE_VALUE (hidden_typelist) == void_type_node);
    2820                 :      59035 :   DECL_ARGUMENTS (fndecl) = arglist;
    2821                 :      59035 : }
    2822                 :            : 
    2823                 :            : /* Do the setup necessary before generating the body of a function.  */
    2824                 :            : 
    2825                 :            : static void
    2826                 :      59035 : trans_function_start (gfc_symbol * sym)
    2827                 :            : {
    2828                 :      59035 :   tree fndecl;
    2829                 :            : 
    2830                 :      59035 :   fndecl = sym->backend_decl;
    2831                 :            : 
    2832                 :            :   /* Let GCC know the current scope is this function.  */
    2833                 :      59035 :   current_function_decl = fndecl;
    2834                 :            : 
    2835                 :            :   /* Let the world know what we're about to do.  */
    2836                 :      59035 :   announce_function (fndecl);
    2837                 :            : 
    2838                 :      59035 :   if (DECL_FILE_SCOPE_P (fndecl))
    2839                 :            :     {
    2840                 :            :       /* Create RTL for function declaration.  */
    2841                 :      30901 :       rest_of_decl_compilation (fndecl, 1, 0);
    2842                 :            :     }
    2843                 :            : 
    2844                 :            :   /* Create RTL for function definition.  */
    2845                 :      59035 :   make_decl_rtl (fndecl);
    2846                 :            : 
    2847                 :      59035 :   allocate_struct_function (fndecl, false);
    2848                 :            : 
    2849                 :            :   /* function.c requires a push at the start of the function.  */
    2850                 :      59035 :   pushlevel ();
    2851                 :      59035 : }
    2852                 :            : 
    2853                 :            : /* Create thunks for alternate entry points.  */
    2854                 :            : 
    2855                 :            : static void
    2856                 :        574 : build_entry_thunks (gfc_namespace * ns, bool global)
    2857                 :            : {
    2858                 :        574 :   gfc_formal_arglist *formal;
    2859                 :        574 :   gfc_formal_arglist *thunk_formal;
    2860                 :        574 :   gfc_entry_list *el;
    2861                 :        574 :   gfc_symbol *thunk_sym;
    2862                 :        574 :   stmtblock_t body;
    2863                 :        574 :   tree thunk_fndecl;
    2864                 :        574 :   tree tmp;
    2865                 :        574 :   locus old_loc;
    2866                 :            : 
    2867                 :            :   /* This should always be a toplevel function.  */
    2868                 :        574 :   gcc_assert (current_function_decl == NULL_TREE);
    2869                 :            : 
    2870                 :        574 :   gfc_save_backend_locus (&old_loc);
    2871                 :       1799 :   for (el = ns->entries; el; el = el->next)
    2872                 :            :     {
    2873                 :       1225 :       vec<tree, va_gc> *args = NULL;
    2874                 :       1225 :       vec<tree, va_gc> *string_args = NULL;
    2875                 :            : 
    2876                 :       1225 :       thunk_sym = el->sym;
    2877                 :            : 
    2878                 :       1225 :       build_function_decl (thunk_sym, global);
    2879                 :       1225 :       create_function_arglist (thunk_sym);
    2880                 :            : 
    2881                 :       1225 :       trans_function_start (thunk_sym);
    2882                 :            : 
    2883                 :       1225 :       thunk_fndecl = thunk_sym->backend_decl;
    2884                 :            : 
    2885                 :       1225 :       gfc_init_block (&body);
    2886                 :            : 
    2887                 :            :       /* Pass extra parameter identifying this entry point.  */
    2888                 :       1225 :       tmp = build_int_cst (gfc_array_index_type, el->id);
    2889                 :       1225 :       vec_safe_push (args, tmp);
    2890                 :            : 
    2891                 :       1225 :       if (thunk_sym->attr.function)
    2892                 :            :         {
    2893                 :       1032 :           if (gfc_return_by_reference (ns->proc_name))
    2894                 :            :             {
    2895                 :        250 :               tree ref = DECL_ARGUMENTS (current_function_decl);
    2896                 :        250 :               vec_safe_push (args, ref);
    2897                 :        250 :               if (ns->proc_name->ts.type == BT_CHARACTER)
    2898                 :        134 :                 vec_safe_push (args, DECL_CHAIN (ref));
    2899                 :            :             }
    2900                 :            :         }
    2901                 :            : 
    2902                 :       2743 :       for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
    2903                 :       1518 :            formal = formal->next)
    2904                 :            :         {
    2905                 :            :           /* Ignore alternate returns.  */
    2906                 :       1518 :           if (formal->sym == NULL)
    2907                 :         36 :             continue;
    2908                 :            : 
    2909                 :            :           /* We don't have a clever way of identifying arguments, so resort to
    2910                 :            :              a brute-force search.  */
    2911                 :       1482 :           for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
    2912                 :       2619 :                thunk_formal;
    2913                 :       1137 :                thunk_formal = thunk_formal->next)
    2914                 :            :             {
    2915                 :       2201 :               if (thunk_formal->sym == formal->sym)
    2916                 :            :                 break;
    2917                 :            :             }
    2918                 :            : 
    2919                 :       1482 :           if (thunk_formal)
    2920                 :            :             {
    2921                 :            :               /* Pass the argument.  */
    2922                 :       1064 :               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
    2923                 :       1064 :               vec_safe_push (args, thunk_formal->sym->backend_decl);
    2924                 :       1064 :               if (formal->sym->ts.type == BT_CHARACTER)
    2925                 :            :                 {
    2926                 :         84 :                   tmp = thunk_formal->sym->ts.u.cl->backend_decl;
    2927                 :         84 :                   vec_safe_push (string_args, tmp);
    2928                 :            :                 }
    2929                 :            :             }
    2930                 :            :           else
    2931                 :            :             {
    2932                 :            :               /* Pass NULL for a missing argument.  */
    2933                 :        418 :               vec_safe_push (args, null_pointer_node);
    2934                 :        418 :               if (formal->sym->ts.type == BT_CHARACTER)
    2935                 :            :                 {
    2936                 :         28 :                   tmp = build_int_cst (gfc_charlen_type_node, 0);
    2937                 :         28 :                   vec_safe_push (string_args, tmp);
    2938                 :            :                 }
    2939                 :            :             }
    2940                 :            :         }
    2941                 :            : 
    2942                 :            :       /* Call the master function.  */
    2943                 :       1225 :       vec_safe_splice (args, string_args);
    2944                 :       1225 :       tmp = ns->proc_name->backend_decl;
    2945                 :       1225 :       tmp = build_call_expr_loc_vec (input_location, tmp, args);
    2946                 :       1225 :       if (ns->proc_name->attr.mixed_entry_master)
    2947                 :            :         {
    2948                 :        210 :           tree union_decl, field;
    2949                 :        210 :           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
    2950                 :            : 
    2951                 :        420 :           union_decl = build_decl (input_location,
    2952                 :            :                                    VAR_DECL, get_identifier ("__result"),
    2953                 :        210 :                                    TREE_TYPE (master_type));
    2954                 :        210 :           DECL_ARTIFICIAL (union_decl) = 1;
    2955                 :        210 :           DECL_EXTERNAL (union_decl) = 0;
    2956                 :        210 :           TREE_PUBLIC (union_decl) = 0;
    2957                 :        210 :           TREE_USED (union_decl) = 1;
    2958                 :        210 :           layout_decl (union_decl, 0);
    2959                 :        210 :           pushdecl (union_decl);
    2960                 :            : 
    2961                 :        210 :           DECL_CONTEXT (union_decl) = current_function_decl;
    2962                 :        210 :           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    2963                 :        210 :                                  TREE_TYPE (union_decl), union_decl, tmp);
    2964                 :        210 :           gfc_add_expr_to_block (&body, tmp);
    2965                 :            : 
    2966                 :        552 :           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
    2967                 :        342 :                field; field = DECL_CHAIN (field))
    2968                 :        342 :             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
    2969                 :        342 :                 thunk_sym->result->name) == 0)
    2970                 :            :               break;
    2971                 :        210 :           gcc_assert (field != NULL_TREE);
    2972                 :        210 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    2973                 :        210 :                                  TREE_TYPE (field), union_decl, field,
    2974                 :            :                                  NULL_TREE);
    2975                 :        840 :           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    2976                 :        210 :                              TREE_TYPE (DECL_RESULT (current_function_decl)),
    2977                 :        210 :                              DECL_RESULT (current_function_decl), tmp);
    2978                 :        210 :           tmp = build1_v (RETURN_EXPR, tmp);
    2979                 :            :         }
    2980                 :       1015 :       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
    2981                 :       1015 :                != void_type_node)
    2982                 :            :         {
    2983                 :       1194 :           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    2984                 :        597 :                              TREE_TYPE (DECL_RESULT (current_function_decl)),
    2985                 :        597 :                              DECL_RESULT (current_function_decl), tmp);
    2986                 :        597 :           tmp = build1_v (RETURN_EXPR, tmp);
    2987                 :            :         }
    2988                 :       1225 :       gfc_add_expr_to_block (&body, tmp);
    2989                 :            : 
    2990                 :            :       /* Finish off this function and send it for code generation.  */
    2991                 :       1225 :       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
    2992                 :       1225 :       tmp = getdecls ();
    2993                 :       1225 :       poplevel (1, 1);
    2994                 :       1225 :       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
    2995                 :       2450 :       DECL_SAVED_TREE (thunk_fndecl)
    2996                 :       1225 :         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
    2997                 :            :                     DECL_INITIAL (thunk_fndecl));
    2998                 :            : 
    2999                 :            :       /* Output the GENERIC tree.  */
    3000                 :       1225 :       dump_function (TDI_original, thunk_fndecl);
    3001                 :            : 
    3002                 :            :       /* Store the end of the function, so that we get good line number
    3003                 :            :          info for the epilogue.  */
    3004                 :       1225 :       cfun->function_end_locus = input_location;
    3005                 :            : 
    3006                 :            :       /* We're leaving the context of this function, so zap cfun.
    3007                 :            :          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
    3008                 :            :          tree_rest_of_compilation.  */
    3009                 :       1225 :       set_cfun (NULL);
    3010                 :            : 
    3011                 :       1225 :       current_function_decl = NULL_TREE;
    3012                 :            : 
    3013                 :       1225 :       cgraph_node::finalize_function (thunk_fndecl, true);
    3014                 :            : 
    3015                 :            :       /* We share the symbols in the formal argument list with other entry
    3016                 :            :          points and the master function.  Clear them so that they are
    3017                 :            :          recreated for each function.  */
    3018                 :       2334 :       for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
    3019                 :       1109 :            formal = formal->next)
    3020                 :       1109 :         if (formal->sym != NULL)  /* Ignore alternate returns.  */
    3021                 :            :           {
    3022                 :       1064 :             formal->sym->backend_decl = NULL_TREE;
    3023                 :       1064 :             if (formal->sym->ts.type == BT_CHARACTER)
    3024                 :         84 :               formal->sym->ts.u.cl->backend_decl = NULL_TREE;
    3025                 :            :           }
    3026                 :            : 
    3027                 :       1225 :       if (thunk_sym->attr.function)
    3028                 :            :         {
    3029                 :       1032 :           if (thunk_sym->ts.type == BT_CHARACTER)
    3030                 :        136 :             thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
    3031                 :       1032 :           if (thunk_sym->result->ts.type == BT_CHARACTER)
    3032                 :        136 :             thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
    3033                 :            :         }
    3034                 :            :     }
    3035                 :            : 
    3036                 :        574 :   gfc_restore_backend_locus (&old_loc);
    3037                 :        574 : }
    3038                 :            : 
    3039                 :            : 
    3040                 :            : /* Create a decl for a function, and create any thunks for alternate entry
    3041                 :            :    points. If global is true, generate the function in the global binding
    3042                 :            :    level, otherwise in the current binding level (which can be global).  */
    3043                 :            : 
    3044                 :            : void
    3045                 :      57810 : gfc_create_function_decl (gfc_namespace * ns, bool global)
    3046                 :            : {
    3047                 :            :   /* Create a declaration for the master function.  */
    3048                 :      57810 :   build_function_decl (ns->proc_name, global);
    3049                 :            : 
    3050                 :            :   /* Compile the entry thunks.  */
    3051                 :      57810 :   if (ns->entries)
    3052                 :        574 :     build_entry_thunks (ns, global);
    3053                 :            : 
    3054                 :            :   /* Now create the read argument list.  */
    3055                 :      57810 :   create_function_arglist (ns->proc_name);
    3056                 :            : 
    3057                 :      57810 :   if (ns->omp_declare_simd)
    3058                 :         87 :     gfc_trans_omp_declare_simd (ns);
    3059                 :      57810 : }
    3060                 :            : 
    3061                 :            : /* Return the decl used to hold the function return value.  If
    3062                 :            :    parent_flag is set, the context is the parent_scope.  */
    3063                 :            : 
    3064                 :            : tree
    3065                 :      12116 : gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
    3066                 :            : {
    3067                 :      12116 :   tree decl;
    3068                 :      12116 :   tree length;
    3069                 :      12116 :   tree this_fake_result_decl;
    3070                 :      12116 :   tree this_function_decl;
    3071                 :            : 
    3072                 :      12116 :   char name[GFC_MAX_SYMBOL_LEN + 10];
    3073                 :            : 
    3074                 :      12116 :   if (parent_flag)
    3075                 :            :     {
    3076                 :        167 :       this_fake_result_decl = parent_fake_result_decl;
    3077                 :        167 :       this_function_decl = DECL_CONTEXT (current_function_decl);
    3078                 :            :     }
    3079                 :            :   else
    3080                 :            :     {
    3081                 :      11949 :       this_fake_result_decl = current_fake_result_decl;
    3082                 :      11949 :       this_function_decl = current_function_decl;
    3083                 :            :     }
    3084                 :            : 
    3085                 :      12116 :   if (sym
    3086                 :      12066 :       && sym->ns->proc_name->backend_decl == this_function_decl
    3087                 :       5691 :       && sym->ns->proc_name->attr.entry_master
    3088                 :       2022 :       && sym != sym->ns->proc_name)
    3089                 :            :     {
    3090                 :       1271 :       tree t = NULL, var;
    3091                 :       1271 :       if (this_fake_result_decl != NULL)
    3092                 :       1244 :         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
    3093                 :        943 :           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
    3094                 :            :             break;
    3095                 :        830 :       if (t)
    3096                 :        529 :         return TREE_VALUE (t);
    3097                 :        742 :       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
    3098                 :            : 
    3099                 :        742 :       if (parent_flag)
    3100                 :         14 :         this_fake_result_decl = parent_fake_result_decl;
    3101                 :            :       else
    3102                 :        728 :         this_fake_result_decl = current_fake_result_decl;
    3103                 :            : 
    3104                 :        742 :       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
    3105                 :            :         {
    3106                 :        210 :           tree field;
    3107                 :            : 
    3108                 :        552 :           for (field = TYPE_FIELDS (TREE_TYPE (decl));
    3109                 :        342 :                field; field = DECL_CHAIN (field))
    3110                 :        342 :             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
    3111                 :            :                 sym->name) == 0)
    3112                 :            :               break;
    3113                 :            : 
    3114                 :        210 :           gcc_assert (field != NULL_TREE);
    3115                 :        210 :           decl = fold_build3_loc (input_location, COMPONENT_REF,
    3116                 :        210 :                                   TREE_TYPE (field), decl, field, NULL_TREE);
    3117                 :            :         }
    3118                 :            : 
    3119                 :        742 :       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
    3120                 :        742 :       if (parent_flag)
    3121                 :         14 :         gfc_add_decl_to_parent_function (var);
    3122                 :            :       else
    3123                 :        728 :         gfc_add_decl_to_function (var);
    3124                 :            : 
    3125                 :        742 :       SET_DECL_VALUE_EXPR (var, decl);
    3126                 :        742 :       DECL_HAS_VALUE_EXPR_P (var) = 1;
    3127                 :        742 :       GFC_DECL_RESULT (var) = 1;
    3128                 :            : 
    3129                 :        742 :       TREE_CHAIN (this_fake_result_decl)
    3130                 :        742 :           = tree_cons (get_identifier (sym->name), var,
    3131                 :        742 :                        TREE_CHAIN (this_fake_result_decl));
    3132                 :        742 :       return var;
    3133                 :            :     }
    3134                 :            : 
    3135                 :      10845 :   if (this_fake_result_decl != NULL_TREE)
    3136                 :       3393 :     return TREE_VALUE (this_fake_result_decl);
    3137                 :            : 
    3138                 :            :   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
    3139                 :            :      sym is NULL.  */
    3140                 :       7452 :   if (!sym)
    3141                 :            :     return NULL_TREE;
    3142                 :            : 
    3143                 :       7452 :   if (sym->ts.type == BT_CHARACTER)
    3144                 :            :     {
    3145                 :        758 :       if (sym->ts.u.cl->backend_decl == NULL_TREE)
    3146                 :          0 :         length = gfc_create_string_length (sym);
    3147                 :            :       else
    3148                 :            :         length = sym->ts.u.cl->backend_decl;
    3149                 :       1239 :       if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE)
    3150                 :        454 :         gfc_add_decl_to_function (length);
    3151                 :            :     }
    3152                 :            : 
    3153                 :       7452 :   if (gfc_return_by_reference (sym))
    3154                 :            :     {
    3155                 :       1427 :       decl = DECL_ARGUMENTS (this_function_decl);
    3156                 :            : 
    3157                 :       1427 :       if (sym->ns->proc_name->backend_decl == this_function_decl
    3158                 :        383 :           && sym->ns->proc_name->attr.entry_master)
    3159                 :         60 :         decl = DECL_CHAIN (decl);
    3160                 :            : 
    3161                 :       1427 :       TREE_USED (decl) = 1;
    3162                 :       1427 :       if (sym->as)
    3163                 :        715 :         decl = gfc_build_dummy_array_decl (sym, decl);
    3164                 :            :     }
    3165                 :            :   else
    3166                 :            :     {
    3167                 :       6025 :       sprintf (name, "__result_%.20s",
    3168                 :       6025 :                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
    3169                 :            : 
    3170                 :       6025 :       if (!sym->attr.mixed_entry_master && sym->attr.function)
    3171                 :       5887 :         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
    3172                 :            :                            VAR_DECL, get_identifier (name),
    3173                 :            :                            gfc_sym_type (sym));
    3174                 :            :       else
    3175                 :        276 :         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
    3176                 :            :                            VAR_DECL, get_identifier (name),
    3177                 :        138 :                            TREE_TYPE (TREE_TYPE (this_function_decl)));
    3178                 :       6025 :       DECL_ARTIFICIAL (decl) = 1;
    3179                 :       6025 :       DECL_EXTERNAL (decl) = 0;
    3180                 :       6025 :       TREE_PUBLIC (decl) = 0;
    3181                 :       6025 :       TREE_USED (decl) = 1;
    3182                 :       6025 :       GFC_DECL_RESULT (decl) = 1;
    3183                 :       6025 :       TREE_ADDRESSABLE (decl) = 1;
    3184                 :            : 
    3185                 :       6025 :       layout_decl (decl, 0);
    3186                 :       6025 :       gfc_finish_decl_attrs (decl, &sym->attr);
    3187                 :            : 
    3188                 :       6025 :       if (parent_flag)
    3189                 :         27 :         gfc_add_decl_to_parent_function (decl);
    3190                 :            :       else
    3191                 :       5998 :         gfc_add_decl_to_function (decl);
    3192                 :            :     }
    3193                 :            : 
    3194                 :       7452 :   if (parent_flag)
    3195                 :         39 :     parent_fake_result_decl = build_tree_list (NULL, decl);
    3196                 :            :   else
    3197                 :       7413 :     current_fake_result_decl = build_tree_list (NULL, decl);
    3198                 :            : 
    3199                 :            :   return decl;
    3200                 :            : }
    3201                 :            : 
    3202                 :            : 
    3203                 :            : /* Builds a function decl.  The remaining parameters are the types of the
    3204                 :            :    function arguments.  Negative nargs indicates a varargs function.  */
    3205                 :            : 
    3206                 :            : static tree
    3207                 :    3506410 : build_library_function_decl_1 (tree name, const char *spec,
    3208                 :            :                                tree rettype, int nargs, va_list p)
    3209                 :            : {
    3210                 :    3506410 :   vec<tree, va_gc> *arglist;
    3211                 :    3506410 :   tree fntype;
    3212                 :    3506410 :   tree fndecl;
    3213                 :    3506410 :   int n;
    3214                 :            : 
    3215                 :            :   /* Library functions must be declared with global scope.  */
    3216                 :    3506410 :   gcc_assert (current_function_decl == NULL_TREE);
    3217                 :            : 
    3218                 :            :   /* Create a list of the argument types.  */
    3219                 :    3506410 :   vec_alloc (arglist, abs (nargs));
    3220                 :   13573000 :   for (n = abs (nargs); n > 0; n--)
    3221                 :            :     {
    3222                 :   10066600 :       tree argtype = va_arg (p, tree);
    3223                 :   10066600 :       arglist->quick_push (argtype);
    3224                 :            :     }
    3225                 :            : 
    3226                 :            :   /* Build the function type and decl.  */
    3227                 :    3506410 :   if (nargs >= 0)
    3228                 :   10014100 :     fntype = build_function_type_vec (rettype, arglist);
    3229                 :            :   else
    3230                 :     453204 :     fntype = build_varargs_function_type_vec (rettype, arglist);
    3231                 :    3506410 :   if (spec)
    3232                 :            :     {
    3233                 :    2099390 :       tree attr_args = build_tree_list (NULL_TREE,
    3234                 :    2099390 :                                         build_string (strlen (spec), spec));
    3235                 :    4198790 :       tree attrs = tree_cons (get_identifier ("fn spec"),
    3236                 :    2099390 :                               attr_args, TYPE_ATTRIBUTES (fntype));
    3237                 :    2099390 :       fntype = build_type_attribute_variant (fntype, attrs);
    3238                 :            :     }
    3239                 :    3506410 :   fndecl = build_decl (input_location,
    3240                 :            :                        FUNCTION_DECL, name, fntype);
    3241                 :            : 
    3242                 :            :   /* Mark this decl as external.  */
    3243                 :    3506410 :   DECL_EXTERNAL (fndecl) = 1;
    3244                 :    3506410 :   TREE_PUBLIC (fndecl) = 1;
    3245                 :            : 
    3246                 :    3506410 :   pushdecl (fndecl);
    3247                 :            : 
    3248                 :    3506410 :   rest_of_decl_compilation (fndecl, 1, 0);
    3249                 :            : 
    3250                 :    3506410 :   return fndecl;
    3251                 :            : }
    3252                 :            : 
    3253                 :            : /* Builds a function decl.  The remaining parameters are the types of the
    3254                 :            :    function arguments.  Negative nargs indicates a varargs function.  */
    3255                 :            : 
    3256                 :            : tree
    3257                 :    1407010 : gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
    3258                 :            : {
    3259                 :    1407010 :   tree ret;
    3260                 :    1407010 :   va_list args;
    3261                 :    1407010 :   va_start (args, nargs);
    3262                 :    1407010 :   ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
    3263                 :    1407010 :   va_end (args);
    3264                 :    1407010 :   return ret;
    3265                 :            : }
    3266                 :            : 
    3267                 :            : /* Builds a function decl.  The remaining parameters are the types of the
    3268                 :            :    function arguments.  Negative nargs indicates a varargs function.
    3269                 :            :    The SPEC parameter specifies the function argument and return type
    3270                 :            :    specification according to the fnspec function type attribute.  */
    3271                 :            : 
    3272                 :            : tree
    3273                 :    2099390 : gfc_build_library_function_decl_with_spec (tree name, const char *spec,
    3274                 :            :                                            tree rettype, int nargs, ...)
    3275                 :            : {
    3276                 :    2099390 :   tree ret;
    3277                 :    2099390 :   va_list args;
    3278                 :    2099390 :   va_start (args, nargs);
    3279                 :    2099390 :   ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
    3280                 :    2099390 :   va_end (args);
    3281                 :    2099390 :   return ret;
    3282                 :            : }
    3283                 :            : 
    3284                 :            : static void
    3285                 :      25178 : gfc_build_intrinsic_function_decls (void)
    3286                 :            : {
    3287                 :      25178 :   tree gfc_int4_type_node = gfc_get_int_type (4);
    3288                 :      25178 :   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
    3289                 :      25178 :   tree gfc_int8_type_node = gfc_get_int_type (8);
    3290                 :      25178 :   tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
    3291                 :      25178 :   tree gfc_int16_type_node = gfc_get_int_type (16);
    3292                 :      25178 :   tree gfc_logical4_type_node = gfc_get_logical_type (4);
    3293                 :      25178 :   tree pchar1_type_node = gfc_get_pchar_type (1);
    3294                 :      25178 :   tree pchar4_type_node = gfc_get_pchar_type (4);
    3295                 :            : 
    3296                 :            :   /* String functions.  */
    3297                 :      25178 :   gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
    3298                 :            :         get_identifier (PREFIX("compare_string")), "..R.R",
    3299                 :            :         integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
    3300                 :            :         gfc_charlen_type_node, pchar1_type_node);
    3301                 :      25178 :   DECL_PURE_P (gfor_fndecl_compare_string) = 1;
    3302                 :      25178 :   TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
    3303                 :            : 
    3304                 :      25178 :   gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
    3305                 :            :         get_identifier (PREFIX("concat_string")), "..W.R.R",
    3306                 :            :         void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
    3307                 :            :         gfc_charlen_type_node, pchar1_type_node,
    3308                 :            :         gfc_charlen_type_node, pchar1_type_node);
    3309                 :      25178 :   TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
    3310                 :            : 
    3311                 :      25178 :   gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
    3312                 :            :         get_identifier (PREFIX("string_len_trim")), "..R",
    3313                 :            :         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
    3314                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
    3315                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
    3316                 :            : 
    3317                 :      25178 :   gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
    3318                 :            :         get_identifier (PREFIX("string_index")), "..R.R.",
    3319                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
    3320                 :            :         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
    3321                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_index) = 1;
    3322                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_index) = 1;
    3323                 :            : 
    3324                 :      25178 :   gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
    3325                 :            :         get_identifier (PREFIX("string_scan")), "..R.R.",
    3326                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
    3327                 :            :         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
    3328                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_scan) = 1;
    3329                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
    3330                 :            : 
    3331                 :      25178 :   gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
    3332                 :            :         get_identifier (PREFIX("string_verify")), "..R.R.",
    3333                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
    3334                 :            :         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
    3335                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_verify) = 1;
    3336                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
    3337                 :            : 
    3338                 :      25178 :   gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
    3339                 :            :         get_identifier (PREFIX("string_trim")), ".Ww.R",
    3340                 :            :         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
    3341                 :            :         build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
    3342                 :            :         pchar1_type_node);
    3343                 :            : 
    3344                 :      25178 :   gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
    3345                 :            :         get_identifier (PREFIX("string_minmax")), ".Ww.R",
    3346                 :            :         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
    3347                 :            :         build_pointer_type (pchar1_type_node), integer_type_node,
    3348                 :            :         integer_type_node);
    3349                 :            : 
    3350                 :      25178 :   gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
    3351                 :            :         get_identifier (PREFIX("adjustl")), ".W.R",
    3352                 :            :         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
    3353                 :            :         pchar1_type_node);
    3354                 :      25178 :   TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
    3355                 :            : 
    3356                 :      25178 :   gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
    3357                 :            :         get_identifier (PREFIX("adjustr")), ".W.R",
    3358                 :            :         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
    3359                 :            :         pchar1_type_node);
    3360                 :      25178 :   TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
    3361                 :            : 
    3362                 :      25178 :   gfor_fndecl_select_string =  gfc_build_library_function_decl_with_spec (
    3363                 :            :         get_identifier (PREFIX("select_string")), ".R.R.",
    3364                 :            :         integer_type_node, 4, pvoid_type_node, integer_type_node,
    3365                 :            :         pchar1_type_node, gfc_charlen_type_node);
    3366                 :      25178 :   DECL_PURE_P (gfor_fndecl_select_string) = 1;
    3367                 :      25178 :   TREE_NOTHROW (gfor_fndecl_select_string) = 1;
    3368                 :            : 
    3369                 :      25178 :   gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
    3370                 :            :         get_identifier (PREFIX("compare_string_char4")), "..R.R",
    3371                 :            :         integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
    3372                 :            :         gfc_charlen_type_node, pchar4_type_node);
    3373                 :      25178 :   DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
    3374                 :      25178 :   TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
    3375                 :            : 
    3376                 :      25178 :   gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
    3377                 :            :         get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
    3378                 :            :         void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
    3379                 :            :         gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
    3380                 :            :         pchar4_type_node);
    3381                 :      25178 :   TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
    3382                 :            : 
    3383                 :      25178 :   gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
    3384                 :            :         get_identifier (PREFIX("string_len_trim_char4")), "..R",
    3385                 :            :         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
    3386                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
    3387                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
    3388                 :            : 
    3389                 :      25178 :   gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
    3390                 :            :         get_identifier (PREFIX("string_index_char4")), "..R.R.",
    3391                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
    3392                 :            :         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
    3393                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
    3394                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
    3395                 :            : 
    3396                 :      25178 :   gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
    3397                 :            :         get_identifier (PREFIX("string_scan_char4")), "..R.R.",
    3398                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
    3399                 :            :         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
    3400                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
    3401                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
    3402                 :            : 
    3403                 :      25178 :   gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
    3404                 :            :         get_identifier (PREFIX("string_verify_char4")), "..R.R.",
    3405                 :            :         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
    3406                 :            :         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
    3407                 :      25178 :   DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
    3408                 :      25178 :   TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
    3409                 :            : 
    3410                 :      25178 :   gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
    3411                 :            :         get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
    3412                 :            :         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
    3413                 :            :         build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
    3414                 :            :         pchar4_type_node);
    3415                 :            : 
    3416                 :      25178 :   gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
    3417                 :            :         get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
    3418                 :            :         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
    3419                 :            :         build_pointer_type (pchar4_type_node), integer_type_node,
    3420                 :            :         integer_type_node);
    3421                 :            : 
    3422                 :      25178 :   gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
    3423                 :            :         get_identifier (PREFIX("adjustl_char4")), ".W.R",
    3424                 :            :         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
    3425                 :            :         pchar4_type_node);
    3426                 :      25178 :   TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
    3427                 :            : 
    3428                 :      25178 :   gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
    3429                 :            :         get_identifier (PREFIX("adjustr_char4")), ".W.R",
    3430                 :            :         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
    3431                 :            :         pchar4_type_node);
    3432                 :      25178 :   TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
    3433                 :            : 
    3434                 :      25178 :   gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
    3435                 :            :         get_identifier (PREFIX("select_string_char4")), ".R.R.",
    3436                 :            :         integer_type_node, 4, pvoid_type_node, integer_type_node,
    3437                 :            :         pvoid_type_node, gfc_charlen_type_node);
    3438                 :      25178 :   DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
    3439                 :      25178 :   TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
    3440                 :            : 
    3441                 :            : 
    3442                 :            :   /* Conversion between character kinds.  */
    3443                 :            : 
    3444                 :      25178 :   gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
    3445                 :            :         get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
    3446                 :            :         void_type_node, 3, build_pointer_type (pchar4_type_node),
    3447                 :            :         gfc_charlen_type_node, pchar1_type_node);
    3448                 :            : 
    3449                 :      25178 :   gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
    3450                 :            :         get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
    3451                 :            :         void_type_node, 3, build_pointer_type (pchar1_type_node),
    3452                 :            :         gfc_charlen_type_node, pchar4_type_node);
    3453                 :            : 
    3454                 :            :   /* Misc. functions.  */
    3455                 :            : 
    3456                 :      25178 :   gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
    3457                 :            :         get_identifier (PREFIX("ttynam")), ".W",
    3458                 :            :         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
    3459                 :            :         integer_type_node);
    3460                 :            : 
    3461                 :      25178 :   gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
    3462                 :            :         get_identifier (PREFIX("fdate")), ".W",
    3463                 :            :         void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
    3464                 :            : 
    3465                 :      25178 :   gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
    3466                 :            :         get_identifier (PREFIX("ctime")), ".W",
    3467                 :            :         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
    3468                 :            :         gfc_int8_type_node);
    3469                 :            : 
    3470                 :      25178 :   gfor_fndecl_random_init = gfc_build_library_function_decl (
    3471                 :            :         get_identifier (PREFIX("random_init")),
    3472                 :            :         void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
    3473                 :            :         gfc_int4_type_node);
    3474                 :            : 
    3475                 :      25178 :   gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
    3476                 :            :         get_identifier (PREFIX("selected_char_kind")), "..R",
    3477                 :            :         gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
    3478                 :      25178 :   DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
    3479                 :      25178 :   TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
    3480                 :            : 
    3481                 :      25178 :   gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
    3482                 :            :         get_identifier (PREFIX("selected_int_kind")), ".R",
    3483                 :            :         gfc_int4_type_node, 1, pvoid_type_node);
    3484                 :      25178 :   DECL_PURE_P (gfor_fndecl_si_kind) = 1;
    3485                 :      25178 :   TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
    3486                 :            : 
    3487                 :      25178 :   gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
    3488                 :            :         get_identifier (PREFIX("selected_real_kind2008")), ".RR",
    3489                 :            :         gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
    3490                 :            :         pvoid_type_node);
    3491                 :      25178 :   DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
    3492                 :      25178 :   TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
    3493                 :            : 
    3494                 :      25178 :   gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
    3495                 :            :         get_identifier (PREFIX("system_clock_4")),
    3496                 :            :         void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
    3497                 :            :         gfc_pint4_type_node);
    3498                 :            : 
    3499                 :      25178 :   gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
    3500                 :            :         get_identifier (PREFIX("system_clock_8")),
    3501                 :            :         void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
    3502                 :            :         gfc_pint8_type_node);
    3503                 :            : 
    3504                 :            :   /* Power functions.  */
    3505                 :      25178 :   {
    3506                 :      25178 :     tree ctype, rtype, itype, jtype;
    3507                 :      25178 :     int rkind, ikind, jkind;
    3508                 :            : #define NIKINDS 3
    3509                 :            : #define NRKINDS 4
    3510                 :      25178 :     static int ikinds[NIKINDS] = {4, 8, 16};
    3511                 :      25178 :     static int rkinds[NRKINDS] = {4, 8, 10, 16};
    3512                 :      25178 :     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
    3513                 :            : 
    3514                 :     100712 :     for (ikind=0; ikind < NIKINDS; ikind++)
    3515                 :            :       {
    3516                 :      75534 :         itype = gfc_get_int_type (ikinds[ikind]);
    3517                 :            : 
    3518                 :     302136 :         for (jkind=0; jkind < NIKINDS; jkind++)
    3519                 :            :           {
    3520                 :     226602 :             jtype = gfc_get_int_type (ikinds[jkind]);
    3521                 :     226602 :             if (itype && jtype)
    3522                 :            :               {
    3523                 :     224897 :                 sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
    3524                 :            :                         ikinds[jkind]);
    3525                 :     449794 :                 gfor_fndecl_math_powi[jkind][ikind].integer =
    3526                 :     224897 :                   gfc_build_library_function_decl (get_identifier (name),
    3527                 :            :                     jtype, 2, jtype, itype);
    3528                 :     224897 :                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
    3529                 :     224897 :                 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
    3530                 :            :               }
    3531                 :            :           }
    3532                 :            : 
    3533                 :     377670 :         for (rkind = 0; rkind < NRKINDS; rkind ++)
    3534                 :            :           {
    3535                 :     302136 :             rtype = gfc_get_real_type (rkinds[rkind]);
    3536                 :     302136 :             if (rtype && itype)
    3537                 :            :               {
    3538                 :     300772 :                 sprintf (name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
    3539                 :            :                         ikinds[ikind]);
    3540                 :     601544 :                 gfor_fndecl_math_powi[rkind][ikind].real =
    3541                 :     300772 :                   gfc_build_library_function_decl (get_identifier (name),
    3542                 :            :                     rtype, 2, rtype, itype);
    3543                 :     300772 :                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
    3544                 :     300772 :                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
    3545                 :            :               }
    3546                 :            : 
    3547                 :     302136 :             ctype = gfc_get_complex_type (rkinds[rkind]);
    3548                 :     302136 :             if (ctype && itype)
    3549                 :            :               {
    3550                 :     300772 :                 sprintf (name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
    3551                 :            :                         ikinds[ikind]);
    3552                 :     601544 :                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
    3553                 :     300772 :                   gfc_build_library_function_decl (get_identifier (name),
    3554                 :            :                     ctype, 2,ctype, itype);
    3555                 :     300772 :                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
    3556                 :     300772 :                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
    3557                 :            :               }
    3558                 :            :           }
    3559                 :            :       }
    3560                 :            : #undef NIKINDS
    3561                 :            : #undef NRKINDS
    3562                 :            :   }
    3563                 :            : 
    3564                 :      25178 :   gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
    3565                 :            :         get_identifier (PREFIX("ishftc4")),
    3566                 :            :         gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
    3567                 :            :         gfc_int4_type_node);
    3568                 :      25178 :   TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
    3569                 :      25178 :   TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
    3570                 :            : 
    3571                 :      25178 :   gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
    3572                 :            :         get_identifier (PREFIX("ishftc8")),
    3573                 :            :         gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
    3574                 :            :         gfc_int4_type_node);
    3575                 :      25178 :   TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
    3576                 :      25178 :   TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
    3577                 :            : 
    3578                 :      25178 :   if (gfc_int16_type_node)
    3579                 :            :     {
    3580                 :      24837 :       gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
    3581                 :            :         get_identifier (PREFIX("ishftc16")),
    3582                 :            :         gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
    3583                 :            :         gfc_int4_type_node);
    3584                 :      24837 :       TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
    3585                 :      24837 :       TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
    3586                 :            :     }
    3587                 :            : 
    3588                 :            :   /* BLAS functions.  */
    3589                 :      25178 :   {
    3590                 :      25178 :     tree pint = build_pointer_type (integer_type_node);
    3591                 :      25178 :     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
    3592                 :      25178 :     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
    3593                 :      25178 :     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
    3594                 :      25178 :     tree pz = build_pointer_type
    3595                 :      25178 :                 (gfc_get_complex_type (gfc_default_double_kind));
    3596                 :            : 
    3597                 :      50356 :     gfor_fndecl_sgemm = gfc_build_library_function_decl
    3598                 :      25821 :                           (get_identifier
    3599                 :            :                              (flag_underscoring ? "sgemm_" : "sgemm"),
    3600                 :            :                            void_type_node, 15, pchar_type_node,
    3601                 :            :                            pchar_type_node, pint, pint, pint, ps, ps, pint,
    3602                 :            :                            ps, pint, ps, ps, pint, integer_type_node,
    3603                 :            :                            integer_type_node);
    3604                 :      50356 :     gfor_fndecl_dgemm = gfc_build_library_function_decl
    3605                 :      25821 :                           (get_identifier
    3606                 :            :                              (flag_underscoring ? "dgemm_" : "dgemm"),
    3607                 :            :                            void_type_node, 15, pchar_type_node,
    3608                 :            :                            pchar_type_node, pint, pint, pint, pd, pd, pint,
    3609                 :            :                            pd, pint, pd, pd, pint, integer_type_node,
    3610                 :            :                            integer_type_node);
    3611                 :      50356 :     gfor_fndecl_cgemm = gfc_build_library_function_decl
    3612                 :      25821 :                           (get_identifier
    3613                 :            :                              (flag_underscoring ? "cgemm_" : "cgemm"),
    3614                 :            :                            void_type_node, 15, pchar_type_node,
    3615                 :            :                            pchar_type_node, pint, pint, pint, pc, pc, pint,
    3616                 :            :                            pc, pint, pc, pc, pint, integer_type_node,
    3617                 :            :                            integer_type_node);
    3618                 :      50356 :     gfor_fndecl_zgemm = gfc_build_library_function_decl
    3619                 :      25821 :                           (get_identifier
    3620                 :            :                              (flag_underscoring ? "zgemm_" : "zgemm"),
    3621                 :            :                            void_type_node, 15, pchar_type_node,
    3622                 :            :                            pchar_type_node, pint, pint, pint, pz, pz, pint,
    3623                 :            :                            pz, pint, pz, pz, pint, integer_type_node,
    3624                 :            :                            integer_type_node);
    3625                 :            :   }
    3626                 :            : 
    3627                 :            :   /* Other functions.  */
    3628                 :      25178 :   gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
    3629                 :            :         get_identifier (PREFIX("size0")), ".R",
    3630                 :            :         gfc_array_index_type, 1, pvoid_type_node);
    3631                 :      25178 :   DECL_PURE_P (gfor_fndecl_size0) = 1;
    3632                 :      25178 :   TREE_NOTHROW (gfor_fndecl_size0) = 1;
    3633                 :            : 
    3634                 :      25178 :   gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
    3635                 :            :         get_identifier (PREFIX("size1")), ".R",
    3636                 :            :         gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
    3637                 :      25178 :   DECL_PURE_P (gfor_fndecl_size1) = 1;
    3638                 :      25178 :   TREE_NOTHROW (gfor_fndecl_size1) = 1;
    3639                 :            : 
    3640                 :      25178 :   gfor_fndecl_iargc = gfc_build_library_function_decl (
    3641                 :            :         get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
    3642                 :      25178 :   TREE_NOTHROW (gfor_fndecl_iargc) = 1;
    3643                 :            : 
    3644                 :      25178 :   gfor_fndecl_kill_sub = gfc_build_library_function_decl (
    3645                 :            :         get_identifier (PREFIX ("kill_sub")), void_type_node,
    3646                 :            :         3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node);
    3647                 :            : 
    3648                 :      25178 :   gfor_fndecl_kill = gfc_build_library_function_decl (
    3649                 :            :         get_identifier (PREFIX ("kill")), gfc_int4_type_node,
    3650                 :            :         2, gfc_int4_type_node, gfc_int4_type_node);
    3651                 :            : 
    3652                 :      25178 :   gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec (
    3653                 :            :         get_identifier (PREFIX("is_contiguous0")), ".R",
    3654                 :            :         gfc_int4_type_node, 1, pvoid_type_node);
    3655                 :      25178 :   DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1;
    3656                 :      25178 :   TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1;
    3657                 :      25178 : }
    3658                 :            : 
    3659                 :            : 
    3660                 :            : /* Make prototypes for runtime library functions.  */
    3661                 :            : 
    3662                 :            : void
    3663                 :      25178 : gfc_build_builtin_function_decls (void)
    3664                 :            : {
    3665                 :      25178 :   tree gfc_int8_type_node = gfc_get_int_type (8);
    3666                 :            : 
    3667                 :      25178 :   gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
    3668                 :            :         get_identifier (PREFIX("stop_numeric")),
    3669                 :            :         void_type_node, 2, integer_type_node, boolean_type_node);
    3670                 :            :   /* STOP doesn't return.  */
    3671                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
    3672                 :            : 
    3673                 :      25178 :   gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
    3674                 :            :         get_identifier (PREFIX("stop_string")), ".R.",
    3675                 :            :         void_type_node, 3, pchar_type_node, size_type_node,
    3676                 :            :         boolean_type_node);
    3677                 :            :   /* STOP doesn't return.  */
    3678                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
    3679                 :            : 
    3680                 :      25178 :   gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
    3681                 :            :         get_identifier (PREFIX("error_stop_numeric")),
    3682                 :            :         void_type_node, 2, integer_type_node, boolean_type_node);
    3683                 :            :   /* ERROR STOP doesn't return.  */
    3684                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
    3685                 :            : 
    3686                 :      25178 :   gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
    3687                 :            :         get_identifier (PREFIX("error_stop_string")), ".R.",
    3688                 :            :         void_type_node, 3, pchar_type_node, size_type_node,
    3689                 :            :         boolean_type_node);
    3690                 :            :   /* ERROR STOP doesn't return.  */
    3691                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
    3692                 :            : 
    3693                 :      25178 :   gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
    3694                 :            :         get_identifier (PREFIX("pause_numeric")),
    3695                 :            :         void_type_node, 1, gfc_int8_type_node);
    3696                 :            : 
    3697                 :      25178 :   gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
    3698                 :            :         get_identifier (PREFIX("pause_string")), ".R.",
    3699                 :            :         void_type_node, 2, pchar_type_node, size_type_node);
    3700                 :            : 
    3701                 :      25178 :   gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
    3702                 :            :         get_identifier (PREFIX("runtime_error")), ".R",
    3703                 :            :         void_type_node, -1, pchar_type_node);
    3704                 :            :   /* The runtime_error function does not return.  */
    3705                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
    3706                 :            : 
    3707                 :      25178 :   gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
    3708                 :            :         get_identifier (PREFIX("runtime_error_at")), ".RR",
    3709                 :            :         void_type_node, -2, pchar_type_node, pchar_type_node);
    3710                 :            :   /* The runtime_error_at function does not return.  */
    3711                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
    3712                 :            : 
    3713                 :      25178 :   gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
    3714                 :            :         get_identifier (PREFIX("runtime_warning_at")), ".RR",
    3715                 :            :         void_type_node, -2, pchar_type_node, pchar_type_node);
    3716                 :            : 
    3717                 :      25178 :   gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
    3718                 :            :         get_identifier (PREFIX("generate_error")), ".R.R",
    3719                 :            :         void_type_node, 3, pvoid_type_node, integer_type_node,
    3720                 :            :         pchar_type_node);
    3721                 :            : 
    3722                 :      25178 :   gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec (
    3723                 :            :         get_identifier (PREFIX("os_error_at")), ".RR",
    3724                 :            :         void_type_node, -2, pchar_type_node, pchar_type_node);
    3725                 :            :   /* The os_error_at function does not return.  */
    3726                 :      25178 :   TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1;
    3727                 :            : 
    3728                 :      25178 :   gfor_fndecl_set_args = gfc_build_library_function_decl (
    3729                 :            :         get_identifier (PREFIX("set_args")),
    3730                 :            :         void_type_node, 2, integer_type_node,
    3731                 :            :         build_pointer_type (pchar_type_node));
    3732                 :            : 
    3733                 :      25178 :   gfor_fndecl_set_fpe = gfc_build_library_function_decl (
    3734                 :            :         get_identifier (PREFIX("set_fpe")),
    3735                 :            :         void_type_node, 1, integer_type_node);
    3736                 :            : 
    3737                 :      25178 :   gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
    3738                 :            :         get_identifier (PREFIX("ieee_procedure_entry")),
    3739                 :            :         void_type_node, 1, pvoid_type_node);
    3740                 :            : 
    3741                 :      25178 :   gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
    3742                 :            :         get_identifier (PREFIX("ieee_procedure_exit")),
    3743                 :            :         void_type_node, 1, pvoid_type_node);
    3744                 :            : 
    3745                 :            :   /* Keep the array dimension in sync with the call, later in this file.  */
    3746                 :      25178 :   gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
    3747                 :            :         get_identifier (PREFIX("set_options")), "..R",
    3748                 :            :         void_type_node, 2, integer_type_node,
    3749                 :            :         build_pointer_type (integer_type_node));
    3750                 :            : 
    3751                 :      25178 :   gfor_fndecl_set_convert = gfc_build_library_function_decl (
    3752                 :            :         get_identifier (PREFIX("set_convert")),
    3753                 :            :         void_type_node, 1, integer_type_node);
    3754                 :            : 
    3755                 :      25178 :   gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
    3756                 :            :         get_identifier (PREFIX("set_record_marker")),
    3757                 :            :         void_type_node, 1, integer_type_node);
    3758                 :            : 
    3759                 :      25178 :   gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
    3760                 :            :         get_identifier (PREFIX("set_max_subrecord_length")),
    3761                 :            :         void_type_node, 1, integer_type_node);
    3762                 :            : 
    3763                 :      25178 :   gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
    3764                 :            :         get_identifier (PREFIX("internal_pack")), ".r",
    3765                 :            :         pvoid_type_node, 1, pvoid_type_node);
    3766                 :            : 
    3767                 :      25178 :   gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
    3768                 :            :         get_identifier (PREFIX("internal_unpack")), ".wR",
    3769                 :            :         void_type_node, 2, pvoid_type_node, pvoid_type_node);
    3770                 :            : 
    3771                 :            :   /* These two builtins write into what the first argument points to and
    3772                 :            :      read from what the second argument points to, but we can't use R
    3773                 :            :      for that, because the directly pointed structure contains a pointer
    3774                 :            :      which is copied into the descriptor pointed by the first argument,
    3775                 :            :      effectively escaping that way.  See PR92123.  */
    3776                 :      25178 :   gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec (
    3777                 :            :         get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ".w.",
    3778                 :            :         void_type_node, 2, pvoid_type_node, ppvoid_type_node);
    3779                 :            : 
    3780                 :      25178 :   gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec (
    3781                 :            :         get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ".w.",
    3782                 :            :         void_type_node, 2, ppvoid_type_node, pvoid_type_node);
    3783                 :            : 
    3784                 :      25178 :   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
    3785                 :            :         get_identifier (PREFIX("associated")), ".RR",
    3786                 :            :         integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
    3787                 :      25178 :   DECL_PURE_P (gfor_fndecl_associated) = 1;
    3788                 :      25178 :   TREE_NOTHROW (gfor_fndecl_associated) = 1;
    3789                 :            : 
    3790                 :            :   /* Coarray library calls.  */
    3791                 :      25178 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    3792                 :            :     {
    3793                 :        260 :       tree pint_type, pppchar_type;
    3794                 :            : 
    3795                 :        260 :       pint_type = build_pointer_type (integer_type_node);
    3796                 :        260 :       pppchar_type
    3797                 :        260 :         = build_pointer_type (build_pointer_type (pchar_type_node));
    3798                 :            : 
    3799                 :        260 :       gfor_fndecl_caf_init = gfc_build_library_function_decl (
    3800                 :            :         get_identifier (PREFIX("caf_init")), void_type_node,
    3801                 :            :         2, pint_type, pppchar_type);
    3802                 :            : 
    3803                 :        260 :       gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
    3804                 :            :         get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
    3805                 :            : 
    3806                 :        260 :       gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
    3807                 :            :         get_identifier (PREFIX("caf_this_image")), integer_type_node,
    3808                 :            :         1, integer_type_node);
    3809                 :            : 
    3810                 :        260 :       gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
    3811                 :            :         get_identifier (PREFIX("caf_num_images")), integer_type_node,
    3812                 :            :         2, integer_type_node, integer_type_node);
    3813                 :            : 
    3814                 :        260 :       gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
    3815                 :            :         get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7,
    3816                 :            :         size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
    3817                 :            :         pint_type, pchar_type_node, size_type_node);
    3818                 :            : 
    3819                 :        260 :       gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
    3820                 :            :         get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5,
    3821                 :            :         ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
    3822                 :            :         size_type_node);
    3823                 :            : 
    3824                 :        260 :       gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
    3825                 :            :         get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10,
    3826                 :            :         pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
    3827                 :            :         pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
    3828                 :            :         boolean_type_node, pint_type);
    3829                 :            : 
    3830                 :        260 :       gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
    3831                 :            :         get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node, 11,
    3832                 :            :         pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
    3833                 :            :         pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
    3834                 :            :         boolean_type_node, pint_type, pvoid_type_node);
    3835                 :            : 
    3836                 :        260 :       gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
    3837                 :            :         get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
    3838                 :            :         void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
    3839                 :            :         pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
    3840                 :            :         integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
    3841                 :            :         integer_type_node, boolean_type_node, integer_type_node);
    3842                 :            : 
    3843                 :        260 :       gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
    3844                 :            :         get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node,
    3845                 :            :         10, pvoid_type_node, integer_type_node, pvoid_type_node,
    3846                 :            :         pvoid_type_node, integer_type_node, integer_type_node,
    3847                 :            :         boolean_type_node, boolean_type_node, pint_type, integer_type_node);
    3848                 :            : 
    3849                 :        260 :       gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
    3850                 :            :         get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR",
    3851                 :            :         void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node,
    3852                 :            :         pvoid_type_node, integer_type_node, integer_type_node,
    3853                 :            :         boolean_type_node, boolean_type_node, pint_type, integer_type_node);
    3854                 :            : 
    3855                 :        260 :       gfor_fndecl_caf_sendget_by_ref
    3856                 :        260 :           = gfc_build_library_function_decl_with_spec (
    3857                 :            :             get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR",
    3858                 :            :             void_type_node, 13, pvoid_type_node, integer_type_node,
    3859                 :            :             pvoid_type_node, pvoid_type_node, integer_type_node,
    3860                 :            :             pvoid_type_node, integer_type_node, integer_type_node,
    3861                 :            :             boolean_type_node, pint_type, pint_type, integer_type_node,
    3862                 :            :             integer_type_node);
    3863                 :            : 
    3864                 :        260 :       gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
    3865                 :            :         get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
    3866                 :            :         3, pint_type, pchar_type_node, size_type_node);
    3867                 :            : 
    3868                 :        260 :       gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
    3869                 :            :         get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node,
    3870                 :            :         3, pint_type, pchar_type_node, size_type_node);
    3871                 :            : 
    3872                 :        260 :       gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
    3873                 :            :         get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
    3874                 :            :         5, integer_type_node, pint_type, pint_type,
    3875                 :            :         pchar_type_node, size_type_node);
    3876                 :            : 
    3877                 :        260 :       gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
    3878                 :            :         get_identifier (PREFIX("caf_error_stop")),
    3879                 :            :         void_type_node, 1, integer_type_node);
    3880                 :            :       /* CAF's ERROR STOP doesn't return.  */
    3881                 :        260 :       TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
    3882                 :            : 
    3883                 :        260 :       gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
    3884                 :            :         get_identifier (PREFIX("caf_error_stop_str")), ".R.",
    3885                 :            :         void_type_node, 2, pchar_type_node, size_type_node);
    3886                 :            :       /* CAF's ERROR STOP doesn't return.  */
    3887                 :        260 :       TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
    3888                 :            : 
    3889                 :        260 :       gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec (
    3890                 :            :         get_identifier (PREFIX("caf_stop_numeric")), ".R.",
    3891                 :            :         void_type_node, 1, integer_type_node);
    3892                 :            :       /* CAF's STOP doesn't return.  */
    3893                 :        260 :       TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
    3894                 :            : 
    3895                 :        260 :       gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
    3896                 :            :         get_identifier (PREFIX("caf_stop_str")), ".R.",
    3897                 :            :         void_type_node, 2, pchar_type_node, size_type_node);
    3898                 :            :       /* CAF's STOP doesn't return.  */
    3899                 :        260 :       TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
    3900                 :            : 
    3901                 :        260 :       gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
    3902                 :            :         get_identifier (PREFIX("caf_atomic_define")), "R..RW",
    3903                 :            :         void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
    3904                 :            :         pvoid_type_node, pint_type, integer_type_node, integer_type_node);
    3905                 :            : 
    3906                 :        260 :       gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
    3907                 :            :         get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
    3908                 :            :         void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
    3909                 :            :         pvoid_type_node, pint_type, integer_type_node, integer_type_node);
    3910                 :            : 
    3911                 :        260 :       gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
    3912                 :            :         get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
    3913                 :            :         void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
    3914                 :            :         pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
    3915                 :            :         integer_type_node, integer_type_node);
    3916                 :            : 
    3917                 :        260 :       gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
    3918                 :            :         get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
    3919                 :            :         void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
    3920                 :            :         integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
    3921                 :            :         integer_type_node, integer_type_node);
    3922                 :            : 
    3923                 :        260 :       gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
    3924                 :            :         get_identifier (PREFIX("caf_lock")), "R..WWW",
    3925                 :            :         void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
    3926                 :            :         pint_type, pint_type, pchar_type_node, size_type_node);
    3927                 :            : 
    3928                 :        260 :       gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
    3929                 :            :         get_identifier (PREFIX("caf_unlock")), "R..WW",
    3930                 :            :         void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
    3931                 :            :         pint_type, pchar_type_node, size_type_node);
    3932                 :            : 
    3933                 :        260 :       gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
    3934                 :            :         get_identifier (PREFIX("caf_event_post")), "R..WW",
    3935                 :            :         void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
    3936                 :            :         pint_type, pchar_type_node, size_type_node);
    3937                 :            : 
    3938                 :        260 :       gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
    3939                 :            :         get_identifier (PREFIX("caf_event_wait")), "R..WW",
    3940                 :            :         void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
    3941                 :            :         pint_type, pchar_type_node, size_type_node);
    3942                 :            : 
    3943                 :        260 :       gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
    3944                 :            :         get_identifier (PREFIX("caf_event_query")), "R..WW",
    3945                 :            :         void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
    3946                 :            :         pint_type, pint_type);
    3947                 :            : 
    3948                 :        260 :       gfor_fndecl_caf_fail_image = gfc_build_library_function_decl (
    3949                 :            :         get_identifier (PREFIX("caf_fail_image")), void_type_node, 0);
    3950                 :            :       /* CAF's FAIL doesn't return.  */
    3951                 :        260 :       TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1;
    3952                 :            : 
    3953                 :        260 :       gfor_fndecl_caf_failed_images
    3954                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3955                 :            :             get_identifier (PREFIX("caf_failed_images")), "WRR",
    3956                 :            :             void_type_node, 3, pvoid_type_node, ppvoid_type_node,
    3957                 :            :             integer_type_node);
    3958                 :            : 
    3959                 :        260 :       gfor_fndecl_caf_form_team
    3960                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3961                 :            :             get_identifier (PREFIX("caf_form_team")), "RWR",
    3962                 :            :             void_type_node, 3, integer_type_node, ppvoid_type_node,
    3963                 :            :             integer_type_node);
    3964                 :            : 
    3965                 :        260 :       gfor_fndecl_caf_change_team
    3966                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3967                 :            :             get_identifier (PREFIX("caf_change_team")), "RR",
    3968                 :            :             void_type_node, 2, ppvoid_type_node,
    3969                 :            :             integer_type_node);
    3970                 :            : 
    3971                 :        260 :       gfor_fndecl_caf_end_team
    3972                 :        260 :         = gfc_build_library_function_decl (
    3973                 :            :             get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
    3974                 :            : 
    3975                 :        260 :       gfor_fndecl_caf_get_team
    3976                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3977                 :            :             get_identifier (PREFIX("caf_get_team")), "R",
    3978                 :            :             void_type_node, 1, integer_type_node);
    3979                 :            : 
    3980                 :        260 :       gfor_fndecl_caf_sync_team
    3981                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3982                 :            :             get_identifier (PREFIX("caf_sync_team")), "RR",
    3983                 :            :             void_type_node, 2, ppvoid_type_node,
    3984                 :            :             integer_type_node);
    3985                 :            : 
    3986                 :        260 :       gfor_fndecl_caf_team_number
    3987                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3988                 :            :             get_identifier (PREFIX("caf_team_number")), "R",
    3989                 :            :             integer_type_node, 1, integer_type_node);
    3990                 :            : 
    3991                 :        260 :       gfor_fndecl_caf_image_status
    3992                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3993                 :            :             get_identifier (PREFIX("caf_image_status")), "RR",
    3994                 :            :             integer_type_node, 2, integer_type_node, ppvoid_type_node);
    3995                 :            : 
    3996                 :        260 :       gfor_fndecl_caf_stopped_images
    3997                 :        260 :         = gfc_build_library_function_decl_with_spec (
    3998                 :            :             get_identifier (PREFIX("caf_stopped_images")), "WRR",
    3999                 :            :             void_type_node, 3, pvoid_type_node, ppvoid_type_node,
    4000                 :            :             integer_type_node);
    4001                 :            : 
    4002                 :        260 :       gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
    4003                 :            :         get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
    4004                 :            :         void_type_node, 5, pvoid_type_node, integer_type_node,
    4005                 :            :         pint_type, pchar_type_node, size_type_node);
    4006                 :            : 
    4007                 :        260 :       gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
    4008                 :            :         get_identifier (PREFIX("caf_co_max")), "W.WW",
    4009                 :            :         void_type_node, 6, pvoid_type_node, integer_type_node,
    4010                 :            :         pint_type, pchar_type_node, integer_type_node, size_type_node);
    4011                 :            : 
    4012                 :        260 :       gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
    4013                 :            :         get_identifier (PREFIX("caf_co_min")), "W.WW",
    4014                 :            :         void_type_node, 6, pvoid_type_node, integer_type_node,
    4015                 :            :         pint_type, pchar_type_node, integer_type_node, size_type_node);
    4016                 :            : 
    4017                 :        260 :       gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
    4018                 :            :         get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
    4019                 :            :         void_type_node, 8, pvoid_type_node,
    4020                 :            :         build_pointer_type (build_varargs_function_type_list (void_type_node,
    4021                 :            :                                                               NULL_TREE)),
    4022                 :            :         integer_type_node, integer_type_node, pint_type, pchar_type_node,
    4023                 :            :         integer_type_node, size_type_node);
    4024                 :            : 
    4025                 :        260 :       gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
    4026                 :            :         get_identifier (PREFIX("caf_co_sum")), "W.WW",
    4027                 :            :         void_type_node, 5, pvoid_type_node, integer_type_node,
    4028                 :            :         pint_type, pchar_type_node, size_type_node);
    4029                 :            : 
    4030                 :        260 :       gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
    4031                 :            :         get_identifier (PREFIX("caf_is_present")), "RRR",
    4032                 :            :         integer_type_node, 3, pvoid_type_node, integer_type_node,
    4033                 :            :         pvoid_type_node);
    4034                 :            :     }
    4035                 :            : 
    4036                 :      25178 :   gfc_build_intrinsic_function_decls ();
    4037                 :      25178 :   gfc_build_intrinsic_lib_fndecls ();
    4038                 :      25178 :   gfc_build_io_library_fndecls ();
    4039                 :      25178 : }
    4040                 :            : 
    4041                 :            : 
    4042                 :            : /* Evaluate the length of dummy character variables.  */
    4043                 :            : 
    4044                 :            : static void
    4045                 :        688 : gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
    4046                 :            :                            gfc_wrapped_block *block)
    4047                 :            : {
    4048                 :        688 :   stmtblock_t init;
    4049                 :            : 
    4050                 :        688 :   gfc_finish_decl (cl->backend_decl);
    4051                 :            : 
    4052                 :        688 :   gfc_start_block (&init);
    4053                 :            : 
    4054                 :            :   /* Evaluate the string length expression.  */
    4055                 :        688 :   gfc_conv_string_length (cl, NULL, &init);
    4056                 :            : 
    4057                 :        688 :   gfc_trans_vla_type_sizes (sym, &init);
    4058                 :            : 
    4059                 :        688 :   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    4060                 :        688 : }
    4061                 :            : 
    4062                 :            : 
    4063                 :            : /* Allocate and cleanup an automatic character variable.  */
    4064                 :            : 
    4065                 :            : static void
    4066                 :        327 : gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
    4067                 :            : {
    4068                 :        327 :   stmtblock_t init;
    4069                 :        327 :   tree decl;
    4070                 :        327 :   tree tmp;
    4071                 :            : 
    4072                 :        327 :   gcc_assert (sym->backend_decl);
    4073                 :        327 :   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
    4074                 :            : 
    4075                 :        327 :   gfc_init_block (&init);
    4076                 :            : 
    4077                 :            :   /* Evaluate the string length expression.  */
    4078                 :        327 :   gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    4079                 :            : 
    4080                 :        327 :   gfc_trans_vla_type_sizes (sym, &init);
    4081                 :            : 
    4082                 :        327 :   decl = sym->backend_decl;
    4083                 :            : 
    4084                 :            :   /* Emit a DECL_EXPR for this variable, which will cause the
    4085                 :            :      gimplifier to allocate storage, and all that good stuff.  */
    4086                 :        327 :   tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
    4087                 :        327 :   gfc_add_expr_to_block (&init, tmp);
    4088                 :            : 
    4089                 :        327 :   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    4090                 :        327 : }
    4091                 :            : 
    4092                 :            : /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
    4093                 :            : 
    4094                 :            : static void
    4095                 :         96 : gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
    4096                 :            : {
    4097                 :         96 :   stmtblock_t init;
    4098                 :            : 
    4099                 :         96 :   gcc_assert (sym->backend_decl);
    4100                 :         96 :   gfc_start_block (&init);
    4101                 :            : 
    4102                 :            :   /* Set the initial value to length. See the comments in
    4103                 :            :      function gfc_add_assign_aux_vars in this file.  */
    4104                 :         96 :   gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
    4105                 :         96 :                   build_int_cst (gfc_charlen_type_node, -2));
    4106                 :            : 
    4107                 :         96 :   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    4108                 :         96 : }
    4109                 :            : 
    4110                 :            : static void
    4111                 :     104660 : gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
    4112                 :            : {
    4113                 :     104660 :   tree t = *tp, var, val;
    4114                 :            : 
    4115                 :     104660 :   if (t == NULL || t == error_mark_node)
    4116                 :            :     return;
    4117                 :      99956 :   if (TREE_CONSTANT (t) || DECL_P (t))
    4118                 :            :     return;
    4119                 :            : 
    4120                 :      41672 :   if (TREE_CODE (t) == SAVE_EXPR)
    4121                 :            :     {
    4122                 :      23330 :       if (SAVE_EXPR_RESOLVED_P (t))
    4123                 :            :         {
    4124                 :          0 :           *tp = TREE_OPERAND (t, 0);
    4125                 :          0 :           return;
    4126                 :            :         }
    4127                 :      23330 :       val = TREE_OPERAND (t, 0);
    4128                 :            :     }
    4129                 :            :   else
    4130                 :            :     val = t;
    4131                 :            : 
    4132                 :      41672 :   var = gfc_create_var_np (TREE_TYPE (t), NULL);
    4133                 :      41672 :   gfc_add_decl_to_function (var);
    4134                 :      41672 :   gfc_add_modify (body, var, unshare_expr (val));
    4135                 :      41672 :   if (TREE_CODE (t) == SAVE_EXPR)
    4136                 :      23330 :     TREE_OPERAND (t, 0) = var;
    4137                 :      41672 :   *tp = var;
    4138                 :            : }
    4139                 :            : 
    4140                 :            : static void
    4141                 :      58954 : gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
    4142                 :            : {
    4143                 :      58954 :   tree t;
    4144                 :            : 
    4145                 :      58954 :   if (type == NULL || type == error_mark_node)
    4146                 :            :     return;
    4147                 :            : 
    4148                 :      58954 :   type = TYPE_MAIN_VARIANT (type);
    4149                 :            : 
    4150                 :      58954 :   if (TREE_CODE (type) == INTEGER_TYPE)
    4151                 :            :     {
    4152                 :      32286 :       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
    4153                 :      32286 :       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
    4154                 :            : 
    4155                 :      41835 :       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
    4156                 :            :         {
    4157                 :       9549 :           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
    4158                 :       9549 :           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
    4159                 :            :         }
    4160                 :            :     }
    4161                 :      26668 :   else if (TREE_CODE (type) == ARRAY_TYPE)
    4162                 :            :     {
    4163                 :      20044 :       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
    4164                 :      20044 :       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
    4165                 :      20044 :       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
    4166                 :      20044 :       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
    4167                 :            : 
    4168                 :      20044 :       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
    4169                 :            :         {
    4170                 :          0 :           TYPE_SIZE (t) = TYPE_SIZE (type);
    4171                 :          0 :           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
    4172                 :            :         }
    4173                 :            :     }
    4174                 :            : }
    4175                 :            : 
    4176                 :            : /* Make sure all type sizes and array domains are either constant,
    4177                 :            :    or variable or parameter decls.  This is a simplified variant
    4178                 :            :    of gimplify_type_sizes, but we can't use it here, as none of the
    4179                 :            :    variables in the expressions have been gimplified yet.
    4180                 :            :    As type sizes and domains for various variable length arrays
    4181                 :            :    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
    4182                 :            :    time, without this routine gimplify_type_sizes in the middle-end
    4183                 :            :    could result in the type sizes being gimplified earlier than where
    4184                 :            :    those variables are initialized.  */
    4185                 :            : 
    4186                 :            : void
    4187                 :      18457 : gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
    4188                 :            : {
    4189                 :      18457 :   tree type = TREE_TYPE (sym->backend_decl);
    4190                 :            : 
    4191                 :      18457 :   if (TREE_CODE (type) == FUNCTION_TYPE
    4192                 :        988 :       && (sym->attr.function || sym->attr.result || sym->attr.entry))
    4193                 :            :     {
    4194                 :        988 :       if (! current_fake_result_decl)
    4195                 :            :         return;
    4196                 :            : 
    4197                 :        988 :       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
    4198                 :            :     }
    4199                 :            : 
    4200                 :      36430 :   while (POINTER_TYPE_P (type))
    4201                 :      17973 :     type = TREE_TYPE (type);
    4202                 :            : 
    4203                 :      18457 :   if (GFC_DESCRIPTOR_TYPE_P (type))
    4204                 :            :     {
    4205                 :        409 :       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
    4206                 :            : 
    4207                 :        818 :       while (POINTER_TYPE_P (etype))
    4208                 :        409 :         etype = TREE_TYPE (etype);
    4209                 :            : 
    4210                 :        409 :       gfc_trans_vla_type_sizes_1 (etype, body);
    4211                 :            :     }
    4212                 :            : 
    4213                 :      18457 :   gfc_trans_vla_type_sizes_1 (type, body);
    4214                 :            : }
    4215                 :            : 
    4216                 :            : 
    4217                 :            : /* Initialize a derived type by building an lvalue from the symbol
    4218                 :            :    and using trans_assignment to do the work. Set dealloc to false
    4219                 :            :    if no deallocation prior the assignment is needed.  */
    4220                 :            : void
    4221                 :        838 : gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
    4222                 :            : {
    4223                 :        838 :   gfc_expr *e;
    4224                 :        838 :   tree tmp;
    4225                 :        838 :   tree present;
    4226                 :            : 
    4227                 :        838 :   gcc_assert (block);
    4228                 :            : 
    4229                 :            :   /* Initialization of PDTs is done elsewhere.  */
    4230                 :        838 :   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
    4231                 :            :     return;
    4232                 :            : 
    4233                 :        700 :   gcc_assert (!sym->attr.allocatable);
    4234                 :        700 :   gfc_set_sym_referenced (sym);
    4235                 :        700 :   e = gfc_lval_expr_from_sym (sym);
    4236                 :        700 :   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
    4237                 :        889 :   if (sym->attr.dummy && (sym->attr.optional
    4238                 :        700 :                           || sym->ns->proc_name->attr.entry_master))
    4239                 :            :     {
    4240                 :         15 :       present = gfc_conv_expr_present (sym);
    4241                 :         15 :       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
    4242                 :            :                         tmp, build_empty_stmt (input_location));
    4243                 :            :     }
    4244                 :        700 :   gfc_add_expr_to_block (block, tmp);
    4245                 :        700 :   gfc_free_expr (e);
    4246                 :            : }
    4247                 :            : 
    4248                 :            : 
    4249                 :            : /* Initialize INTENT(OUT) derived type dummies.  As well as giving
    4250                 :            :    them their default initializer, if they do not have allocatable
    4251                 :            :    components, they have their allocatable components deallocated.  */
    4252                 :            : 
    4253                 :            : static void
    4254                 :      64772 : init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
    4255                 :            : {
    4256                 :      64772 :   stmtblock_t init;
    4257                 :      64772 :   gfc_formal_arglist *f;
    4258                 :      64772 :   tree tmp;
    4259                 :      64772 :   tree present;
    4260                 :            : 
    4261                 :      64772 :   gfc_init_block (&init);
    4262                 :     128836 :   for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
    4263                 :      64064 :     if (f->sym && f->sym->attr.intent == INTENT_OUT
    4264                 :       2108 :         && !f->sym->attr.pointer
    4265                 :       2094 :         && f->sym->ts.type == BT_DERIVED)
    4266                 :            :       {
    4267                 :        311 :         tmp = NULL_TREE;
    4268                 :            : 
    4269                 :            :         /* Note: Allocatables are excluded as they are already handled
    4270                 :            :            by the caller.  */
    4271                 :        311 :         if (!f->sym->attr.allocatable
    4272                 :        311 :             && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
    4273                 :            :           {
    4274                 :          2 :             stmtblock_t block;
    4275                 :          2 :             gfc_expr *e;
    4276                 :            : 
    4277                 :          2 :             gfc_init_block (&block);
    4278                 :          2 :             f->sym->attr.referenced = 1;
    4279                 :          2 :             e = gfc_lval_expr_from_sym (f->sym);
    4280                 :          2 :             gfc_add_finalizer_call (&block, e);
    4281                 :          2 :             gfc_free_expr (e);
    4282                 :          2 :             tmp = gfc_finish_block (&block);
    4283                 :            :           }
    4284                 :            : 
    4285                 :        311 :         if (tmp == NULL_TREE && !f->sym->attr.allocatable
    4286                 :        258 :             && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
    4287                 :          0 :           tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
    4288                 :            :                                            f->sym->backend_decl,
    4289                 :          0 :                                            f->sym->as ? f->sym->as->rank : 0);
    4290                 :            : 
    4291                 :        311 :         if (tmp != NULL_TREE && (f->sym->attr.optional
    4292                 :          2 :                                  || f->sym->ns->proc_name->attr.entry_master))
    4293                 :            :           {
    4294                 :          0 :             present = gfc_conv_expr_present (f->sym);
    4295                 :          0 :             tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
    4296                 :            :                               present, tmp, build_empty_stmt (input_location));
    4297                 :            :           }
    4298                 :            : 
    4299                 :        311 :         if (tmp != NULL_TREE)
    4300                 :          2 :           gfc_add_expr_to_block (&init, tmp);
    4301                 :        309 :         else if (f->sym->value && !f->sym->attr.allocatable)
    4302                 :        189 :           gfc_init_default_dt (f->sym, &init, true);
    4303                 :            :       }
    4304                 :      63753 :     else if (f->sym && f->sym->attr.intent == INTENT_OUT
    4305                 :       1797 :              && f->sym->ts.type == BT_CLASS
    4306                 :        390 :              && !CLASS_DATA (f->sym)->attr.class_pointer
    4307                 :        390 :              && !CLASS_DATA (f->sym)->attr.allocatable)
    4308                 :            :       {
    4309                 :        270 :         stmtblock_t block;
    4310                 :        270 :         gfc_expr *e;
    4311                 :            : 
    4312                 :        270 :         gfc_init_block (&block);
    4313                 :        270 :         f->sym->attr.referenced = 1;
    4314                 :        270 :         e = gfc_lval_expr_from_sym (f->sym);
    4315                 :        270 :         gfc_add_finalizer_call (&block, e);
    4316                 :        270 :         gfc_free_expr (e);
    4317                 :        270 :         tmp = gfc_finish_block (&block);
    4318                 :            : 
    4319                 :        270 :         if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
    4320                 :            :           {
    4321                 :          6 :             present = gfc_conv_expr_present (f->sym);
    4322                 :          6 :             tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
    4323                 :            :                               present, tmp,
    4324                 :            :                               build_empty_stmt (input_location));
    4325                 :            :           }
    4326                 :            : 
    4327                 :        270 :         gfc_add_expr_to_block (&init, tmp);
    4328                 :            :       }
    4329                 :            : 
    4330                 :      64772 :   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    4331                 :      64772 : }
    4332                 :            : 
    4333                 :            : 
    4334                 :            : /* Helper function to manage deferred string lengths.  */
    4335                 :            : 
    4336                 :            : static tree
    4337                 :        114 : gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
    4338                 :            :                                 locus *loc)
    4339                 :            : {
    4340                 :        114 :   tree tmp;
    4341                 :            : 
    4342                 :            :   /* Character length passed by reference.  */
    4343                 :        114 :   tmp = sym->ts.u.cl->passed_length;
    4344                 :        114 :   tmp = build_fold_indirect_ref_loc (input_location, tmp);
    4345                 :        114 :   tmp = fold_convert (gfc_charlen_type_node, tmp);
    4346                 :            : 
    4347                 :        114 :   if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
    4348                 :            :     /* Zero the string length when entering the scope.  */
    4349                 :        114 :     gfc_add_modify (init, sym->ts.u.cl->backend_decl,
    4350                 :        114 :                     build_int_cst (gfc_charlen_type_node, 0));
    4351                 :            :   else
    4352                 :            :     {
    4353                 :          0 :       tree tmp2;
    4354                 :            : 
    4355                 :          0 :       tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
    4356                 :            :                               gfc_charlen_type_node,
    4357                 :          0 :                               sym->ts.u.cl->backend_decl, tmp);
    4358                 :          0 :       if (sym->attr.optional)
    4359                 :            :         {
    4360                 :          0 :           tree present = gfc_conv_expr_present (sym);
    4361                 :          0 :           tmp2 = build3_loc (input_location, COND_EXPR,
    4362                 :            :                              void_type_node, present, tmp2,
    4363                 :            :                              build_empty_stmt (input_location));
    4364                 :            :         }
    4365                 :          0 :       gfc_add_expr_to_block (init, tmp2);
    4366                 :            :     }
    4367                 :            : 
    4368                 :        114 :   gfc_restore_backend_locus (loc);
    4369                 :            : 
    4370                 :            :   /* Pass the final character length back.  */
    4371                 :        114 :   if (sym->attr.intent != INTENT_IN)
    4372                 :            :     {
    4373                 :        228 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    4374                 :            :                              gfc_charlen_type_node, tmp,
    4375                 :        114 :                              sym->ts.u.cl->backend_decl);
    4376                 :        114 :       if (sym->attr.optional)
    4377                 :            :         {
    4378                 :          0 :           tree present = gfc_conv_expr_present (sym);
    4379                 :          0 :           tmp = build3_loc (input_location, COND_EXPR,
    4380                 :            :                             void_type_node, present, tmp,
    4381                 :            :                             build_empty_stmt (input_location));
    4382                 :            :         }
    4383                 :            :     }
    4384                 :            :   else
    4385                 :            :     tmp = NULL_TREE;
    4386                 :            : 
    4387                 :        114 :   return tmp;
    4388                 :            : }
    4389                 :            : 
    4390                 :            : 
    4391                 :            : /* Convert CFI descriptor dummies into gfc types and back again.  */
    4392                 :            : static void
    4393                 :         45 : convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
    4394                 :            : {
    4395                 :         45 :   tree gfc_desc;
    4396                 :         45 :   tree gfc_desc_ptr;
    4397                 :         45 :   tree CFI_desc;
    4398                 :         45 :   tree CFI_desc_ptr;
    4399                 :         45 :   tree dummy_ptr;
    4400                 :         45 :   tree tmp;
    4401                 :         45 :   tree present;
    4402                 :         45 :   tree incoming;
    4403                 :         45 :   tree outgoing;
    4404                 :         45 :   stmtblock_t outer_block;
    4405                 :         45 :   stmtblock_t tmpblock;
    4406                 :            : 
    4407                 :            :   /* dummy_ptr will be the pointer to the passed array descriptor,
    4408                 :            :      while CFI_desc is the descriptor itself.  */
    4409                 :         45 :   if (DECL_LANG_SPECIFIC (sym->backend_decl))
    4410                 :         32 :     CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
    4411                 :         13 :   else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (sym->backend_decl))))
    4412                 :            :     CFI_desc = sym->backend_decl;
    4413                 :            :   else
    4414                 :            :     CFI_desc = NULL;
    4415                 :            : 
    4416                 :         90 :   dummy_ptr = CFI_desc;
    4417                 :            : 
    4418                 :         45 :   if (CFI_desc)
    4419                 :            :     {
    4420                 :         39 :       CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
    4421                 :            : 
    4422                 :            :       /* The compiler will have given CFI_desc the correct gfortran
    4423                 :            :          type. Use this new variable to store the converted
    4424                 :            :          descriptor.  */
    4425                 :         39 :       gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
    4426                 :         39 :       tmp = build_pointer_type (TREE_TYPE (gfc_desc));
    4427                 :         39 :       gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
    4428                 :         39 :       CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
    4429                 :            : 
    4430                 :            :       /* Fix the condition for the presence of the argument.  */
    4431                 :         39 :       gfc_init_block (&outer_block);
    4432                 :         39 :       present = fold_build2_loc (input_location, NE_EXPR,
    4433                 :            :                                  logical_type_node, dummy_ptr,
    4434                 :         39 :                                  build_int_cst (TREE_TYPE (dummy_ptr), 0));
    4435                 :            : 
    4436                 :         39 :       gfc_init_block (&tmpblock);
    4437                 :            :       /* Pointer to the gfc descriptor.  */
    4438                 :         39 :       gfc_add_modify (&tmpblock, gfc_desc_ptr,
    4439                 :            :                       gfc_build_addr_expr (NULL, gfc_desc));
    4440                 :            :       /* Store the pointer to the CFI descriptor.  */
    4441                 :         39 :       gfc_add_modify (&tmpblock, CFI_desc_ptr,
    4442                 :            :                       fold_convert (pvoid_type_node, dummy_ptr));
    4443                 :         39 :       tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
    4444                 :            :       /* Convert the CFI descriptor.  */
    4445                 :         39 :       incoming = build_call_expr_loc (input_location,
    4446                 :            :                         gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
    4447                 :         39 :       gfc_add_expr_to_block (&tmpblock, incoming);
    4448                 :            :       /* Set the dummy pointer to point to the gfc_descriptor.  */
    4449                 :         78 :       gfc_add_modify (&tmpblock, dummy_ptr,
    4450                 :         39 :                       fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
    4451                 :            : 
    4452                 :            :       /* The hidden string length is not passed to bind(C) procedures so set
    4453                 :            :          it from the descriptor element length.  */
    4454                 :         39 :       if (sym->ts.type == BT_CHARACTER
    4455                 :          1 :           && sym->ts.u.cl->backend_decl
    4456                 :          1 :           && VAR_P (sym->ts.u.cl->backend_decl))
    4457                 :            :         {
    4458                 :          1 :           tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
    4459                 :          1 :           tmp = gfc_conv_descriptor_elem_len (tmp);
    4460                 :          1 :           gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
    4461                 :          1 :                           fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
    4462                 :            :                                         tmp));
    4463                 :            :         }
    4464                 :            : 
    4465                 :            :       /* Check that the argument is present before executing the above.  */
    4466                 :         39 :       incoming = build3_v (COND_EXPR, present,
    4467                 :            :                            gfc_finish_block (&tmpblock),
    4468                 :            :                            build_empty_stmt (input_location));
    4469                 :         39 :       gfc_add_expr_to_block (&outer_block, incoming);
    4470                 :         39 :       incoming = gfc_finish_block (&outer_block);
    4471                 :            : 
    4472                 :            : 
    4473                 :            :       /* Convert the gfc descriptor back to the CFI type before going
    4474                 :            :          out of scope, if the CFI type was present at entry.  */
    4475                 :         39 :       gfc_init_block (&outer_block);
    4476                 :         39 :       gfc_init_block (&tmpblock);
    4477                 :            : 
    4478                 :         39 :       tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
    4479                 :         39 :       outgoing = build_call_expr_loc (input_location,
    4480                 :            :                         gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
    4481                 :         39 :       gfc_add_expr_to_block (&tmpblock, outgoing);
    4482                 :            : 
    4483                 :         39 :       outgoing = build3_v (COND_EXPR, present,
    4484                 :            :                            gfc_finish_block (&tmpblock),
    4485                 :            :                            build_empty_stmt (input_location));
    4486                 :         39 :       gfc_add_expr_to_block (&outer_block, outgoing);
    4487                 :         39 :       outgoing = gfc_finish_block (&outer_block);
    4488                 :            : 
    4489                 :            :       /* Add the lot to the procedure init and finally blocks.  */
    4490                 :         39 :       gfc_add_init_cleanup (block, incoming, outgoing);
    4491                 :            :     }
    4492                 :         45 : }
    4493                 :            : 
    4494                 :            : /* Get the result expression for a procedure.  */
    4495                 :            : 
    4496                 :            : static tree
    4497                 :      17457 : get_proc_result (gfc_symbol* sym)
    4498                 :            : {
    4499                 :      17457 :   if (sym->attr.subroutine || sym == sym->result)
    4500                 :            :     {
    4501                 :      12720 :       if (current_fake_result_decl != NULL)
    4502                 :      12563 :         return TREE_VALUE (current_fake_result_decl);
    4503                 :            : 
    4504                 :            :       return NULL_TREE;
    4505                 :            :     }
    4506                 :            : 
    4507                 :       4737 :   return sym->result->backend_decl;
    4508                 :            : }
    4509                 :            : 
    4510                 :            : 
    4511                 :            : /* Generate function entry and exit code, and add it to the function body.
    4512                 :            :    This includes:
    4513                 :            :     Allocation and initialization of array variables.
    4514                 :            :     Allocation of character string variables.
    4515                 :            :     Initialization and possibly repacking of dummy arrays.
    4516                 :            :     Initialization of ASSIGN statement auxiliary variable.
    4517                 :            :     Initialization of ASSOCIATE names.
    4518                 :            :     Automatic deallocation.  */
    4519                 :            : 
    4520                 :            : void
    4521                 :      64772 : gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
    4522                 :            : {
    4523                 :      64772 :   locus loc;
    4524                 :      64772 :   gfc_symbol *sym;
    4525                 :      64772 :   gfc_formal_arglist *f;
    4526                 :      64772 :   stmtblock_t tmpblock;
    4527                 :      64772 :   bool seen_trans_deferred_array = false;
    4528                 :      64772 :   bool is_pdt_type = false;
    4529                 :      64772 :   tree tmp = NULL;
    4530                 :      64772 :   gfc_expr *e;
    4531                 :      64772 :   gfc_se se;
    4532                 :      64772 :   stmtblock_t init;
    4533                 :            : 
    4534                 :            :   /* Deal with implicit return variables.  Explicit return variables will
    4535                 :            :      already have been added.  */
    4536                 :      64772 :   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
    4537                 :            :     {
    4538                 :       1499 :       if (!current_fake_result_decl)
    4539                 :            :         {
    4540                 :         72 :           gfc_entry_list *el = NULL;
    4541                 :         72 :           if (proc_sym->attr.entry_master)
    4542                 :            :             {
    4543                 :         46 :               for (el = proc_sym->ns->entries; el; el = el->next)
    4544                 :         46 :                 if (el->sym != el->sym->result)
    4545                 :            :                   break;
    4546                 :            :             }
    4547                 :            :           /* TODO: move to the appropriate place in resolve.c.  */
    4548                 :         72 :           if (warn_return_type > 0 && el == NULL)
    4549                 :          4 :             gfc_warning (OPT_Wreturn_type,
    4550                 :            :                          "Return value of function %qs at %L not set",
    4551                 :            :                          proc_sym->name, &proc_sym->declared_at);
    4552                 :            :         }
    4553                 :       1427 :       else if (proc_sym->as)
    4554                 :            :         {
    4555                 :        715 :           tree result = TREE_VALUE (current_fake_result_decl);
    4556                 :        715 :           gfc_save_backend_locus (&loc);
    4557                 :        715 :           gfc_set_backend_locus (&proc_sym->declared_at);
    4558                 :        715 :           gfc_trans_dummy_array_bias (proc_sym, result, block);
    4559                 :            : 
    4560                 :            :           /* An automatic character length, pointer array result.  */
    4561                 :        715 :           if (proc_sym->ts.type == BT_CHARACTER
    4562                 :         69 :               && VAR_P (proc_sym->ts.u.cl->backend_decl))
    4563                 :            :             {
    4564                 :         51 :               tmp = NULL;
    4565                 :         51 :               if (proc_sym->ts.deferred)
    4566                 :            :                 {
    4567                 :         12 :                   gfc_start_block (&init);
    4568                 :         12 :                   tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
    4569                 :         12 :                   gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
    4570                 :            :                 }
    4571                 :            :               else
    4572                 :         39 :                 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
    4573                 :            :             }
    4574                 :            :         }
    4575                 :        712 :       else if (proc_sym->ts.type == BT_CHARACTER)
    4576                 :            :         {
    4577                 :        676 :           if (proc_sym->ts.deferred)
    4578                 :            :             {
    4579                 :         71 :               tmp = NULL;
    4580                 :         71 :               gfc_save_backend_locus (&loc);
    4581                 :         71 :               gfc_set_backend_locus (&proc_sym->declared_at);
    4582                 :         71 :               gfc_start_block (&init);
    4583                 :            :               /* Zero the string length on entry.  */
    4584                 :         71 :               gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
    4585                 :         71 :                               build_int_cst (gfc_charlen_type_node, 0));
    4586                 :            :               /* Null the pointer.  */
    4587                 :         71 :               e = gfc_lval_expr_from_sym (proc_sym);
    4588                 :         71 :               gfc_init_se (&se, NULL);
    4589                 :         71 :               se.want_pointer = 1;
    4590                 :         71 :               gfc_conv_expr (&se, e);
    4591                 :         71 :               gfc_free_expr (e);
    4592                 :         71 :               tmp = se.expr;
    4593                 :         71 :               gfc_add_modify (&init, tmp,
    4594                 :         71 :                               fold_convert (TREE_TYPE (se.expr),
    4595                 :            :                                             null_pointer_node));
    4596                 :         71 :               gfc_restore_backend_locus (&loc);
    4597                 :            : 
    4598                 :            :               /* Pass back the string length on exit.  */
    4599                 :         71 :               tmp = proc_sym->ts.u.cl->backend_decl;
    4600                 :         71 :               if (TREE_CODE (tmp) != INDIRECT_REF
    4601                 :         71 :                   && proc_sym->ts.u.cl->passed_length)
    4602                 :            :                 {
    4603                 :         71 :                   tmp = proc_sym->ts.u.cl->passed_length;
    4604                 :         71 :                   tmp = build_fold_indirect_ref_loc (input_location, tmp);
    4605                 :         71 :                   tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    4606                 :         71 :                                          TREE_TYPE (tmp), tmp,
    4607                 :         71 :                                          fold_convert
    4608                 :            :                                          (TREE_TYPE (tmp),
    4609                 :            :                                           proc_sym->ts.u.cl->backend_decl));
    4610                 :            :                 }
    4611                 :            :               else
    4612                 :            :                 tmp = NULL_TREE;
    4613                 :            : 
    4614                 :         71 :               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
    4615                 :            :             }
    4616                 :        605 :           else if (VAR_P (proc_sym->ts.u.cl->backend_decl))
    4617                 :        359 :             gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
    4618                 :            :         }
    4619                 :            :       else
    4620                 :         36 :         gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
    4621                 :            :     }
    4622                 :      63273 :   else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
    4623                 :            :     {
    4624                 :            :       /* Nullify explicit return class arrays on entry.  */
    4625                 :         27 :       tree type;
    4626                 :         27 :       tmp = get_proc_result (proc_sym);
    4627                 :         54 :         if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
    4628                 :            :           {
    4629                 :         27 :             gfc_start_block (&init);
    4630                 :         27 :             tmp = gfc_class_data_get (tmp);
    4631                 :         27 :             type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
    4632                 :         27 :             gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
    4633                 :         27 :             gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
    4634                 :            :           }
    4635                 :            :     }
    4636                 :            : 
    4637                 :            : 
    4638                 :            :   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
    4639                 :            :      should be done here so that the offsets and lbounds of arrays
    4640                 :            :      are available.  */
    4641                 :      64772 :   gfc_save_backend_locus (&loc);
    4642                 :      64772 :   gfc_set_backend_locus (&proc_sym->declared_at);
    4643                 :      64772 :   init_intent_out_dt (proc_sym, block);
    4644                 :      64772 :   gfc_restore_backend_locus (&loc);
    4645                 :            : 
    4646                 :     112640 :   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
    4647                 :            :     {
    4648                 :      47868 :       bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
    4649                 :      47868 :                                 && (sym->ts.u.derived->attr.alloc_comp
    4650                 :       3377 :                                     || gfc_is_finalizable (sym->ts.u.derived,
    4651                 :       7532 :                                                            NULL));
    4652                 :      47868 :       if (sym->assoc)
    4653                 :       2072 :         continue;
    4654                 :            : 
    4655                 :      45796 :       if (sym->ts.type == BT_DERIVED
    4656                 :       6701 :           && sym->ts.u.derived
    4657                 :       6701 :           && sym->ts.u.derived->attr.pdt_type)
    4658                 :            :         {
    4659                 :        292 :           is_pdt_type = true;
    4660                 :        292 :           gfc_init_block (&tmpblock);
    4661                 :        292 :           if (!(sym->attr.dummy
    4662                 :            :                 || sym->attr.pointer
    4663                 :            :                 || sym->attr.allocatable))
    4664                 :            :             {
    4665                 :        144 :               tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
    4666                 :            :                                            sym->backend_decl,
    4667                 :        144 :                                            sym->as ? sym->as->rank : 0,
    4668                 :            :                                            sym->param_list);
    4669                 :        144 :               gfc_add_expr_to_block (&tmpblock, tmp);
    4670                 :        144 :               if (!sym->attr.result)
    4671                 :        138 :                 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
    4672                 :            :                                                sym->backend_decl,
    4673                 :        138 :                                                sym->as ? sym->as->rank : 0);
    4674                 :            :               else
    4675                 :            :                 tmp = NULL_TREE;
    4676                 :        144 :               gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
    4677                 :            :             }
    4678                 :        148 :           else if (sym->attr.dummy)
    4679                 :            :             {
    4680                 :         48 :               tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
    4681                 :            :                                          sym->backend_decl,
    4682                 :         48 :                                          sym->as ? sym->as->rank : 0,
    4683                 :            :                                          sym->param_list);
    4684                 :         48 :               gfc_add_expr_to_block (&tmpblock, tmp);
    4685                 :         48 :               gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
    4686                 :            :             }
    4687                 :            :         }
    4688                 :      45504 :       else if (sym->ts.type == BT_CLASS
    4689                 :       2089 :                && CLASS_DATA (sym)->ts.u.derived
    4690                 :       2089 :                && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
    4691                 :            :         {
    4692                 :         30 :           gfc_component *data = CLASS_DATA (sym);
    4693                 :         30 :           is_pdt_type = true;
    4694                 :         30 :           gfc_init_block (&tmpblock);
    4695                 :         60 :           if (!(sym->attr.dummy
    4696                 :         30 :                 || CLASS_DATA (sym)->attr.pointer
    4697                 :            :                 || CLASS_DATA (sym)->attr.allocatable))
    4698                 :            :             {
    4699                 :          0 :               tmp = gfc_class_data_get (sym->backend_decl);
    4700                 :          0 :               tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
    4701                 :          0 :                                            data->as ? data->as->rank : 0,
    4702                 :            :                                            sym->param_list);
    4703                 :          0 :               gfc_add_expr_to_block (&tmpblock, tmp);
    4704                 :          0 :               tmp = gfc_class_data_get (sym->backend_decl);
    4705                 :          0 :               if (!sym->attr.result)
    4706                 :          0 :                 tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
    4707                 :          0 :                                                data->as ? data->as->rank : 0);
    4708                 :            :               else
    4709                 :            :                 tmp = NULL_TREE;
    4710                 :          0 :               gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
    4711                 :            :             }
    4712                 :         30 :           else if (sym->attr.dummy)
    4713                 :            :             {
    4714                 :          0 :               tmp = gfc_class_data_get (sym->backend_decl);
    4715                 :          0 :               tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
    4716                 :          0 :                                          data->as ? data->as->rank : 0,
    4717                 :            :                                          sym->param_list);
    4718                 :          0 :               gfc_add_expr_to_block (&tmpblock, tmp);
    4719                 :          0 :               gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
    4720                 :            :             }
    4721                 :            :         }
    4722                 :            : 
    4723                 :      45796 :       if (sym->attr.pointer && sym->attr.dimension
    4724                 :            :           && sym->attr.save == SAVE_NONE
    4725                 :            :           && !sym->attr.use_assoc
    4726                 :            :           && !sym->attr.host_assoc
    4727                 :      45796 :           && !sym->attr.dummy
    4728                 :      45796 :           && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
    4729                 :            :         {
    4730                 :       2297 :           gfc_init_block (&tmpblock);
    4731                 :       2297 :           gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
    4732                 :       2297 :                                 build_int_cst (gfc_array_index_type, 0));
    4733                 :       2297 :           gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
    4734                 :            :                                 NULL_TREE);
    4735                 :            :         }
    4736                 :            : 
    4737                 :      45796 :       if (sym->ts.type == BT_CLASS
    4738                 :       2089 :           && (sym->attr.save || flag_max_stack_var_size == 0)
    4739                 :         45 :           && CLASS_DATA (sym)->attr.allocatable)
    4740                 :            :         {
    4741                 :         39 :           tree vptr;
    4742                 :            : 
    4743                 :         39 :           if (UNLIMITED_POLY (sym))
    4744                 :          0 :             vptr = null_pointer_node;
    4745                 :            :           else
    4746                 :            :             {
    4747                 :         39 :               gfc_symbol *vsym;
    4748                 :         39 :               vsym = gfc_find_derived_vtab (sym->ts.u.derived);
    4749                 :         39 :               vptr = gfc_get_symbol_decl (vsym);
    4750                 :         39 :               vptr = gfc_build_addr_expr (NULL, vptr);
    4751                 :            :             }
    4752                 :            : 
    4753                 :         39 :           if (CLASS_DATA (sym)->attr.dimension
    4754                 :          7 :               || (CLASS_DATA (sym)->attr.codimension
    4755                 :         39 :                   && flag_coarray != GFC_FCOARRAY_LIB))
    4756                 :            :             {
    4757                 :         33 :               tmp = gfc_class_data_get (sym->backend_decl);
    4758                 :         33 :               tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
    4759                 :            :             }
    4760                 :            :           else
    4761                 :          6 :             tmp = null_pointer_node;
    4762                 :            : 
    4763                 :         78 :           DECL_INITIAL (sym->backend_decl)
    4764                 :         39 :                 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
    4765                 :         39 :           TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
    4766                 :            :         }
    4767                 :      45757 :       else if ((sym->attr.dimension || sym->attr.codimension
    4768                 :       7704 :                || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
    4769                 :            :         {
    4770                 :      38437 :           bool is_classarray = IS_CLASS_ARRAY (sym);
    4771                 :      38437 :           symbol_attribute *array_attr;
    4772                 :      38437 :           gfc_array_spec *as;
    4773                 :      38437 :           array_type type_of_array;
    4774                 :            : 
    4775                 :      38437 :           array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
    4776                 :      38437 :           as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
    4777                 :            :           /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT.  */
    4778                 :      38437 :           type_of_array = as->type;
    4779                 :      38437 :           if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
    4780                 :            :             type_of_array = AS_EXPLICIT;
    4781                 :      38366 :           switch (type_of_array)
    4782                 :            :             {
    4783                 :      27138 :             case AS_EXPLICIT:
    4784                 :      27138 :               if (sym->attr.dummy || sym->attr.result)
    4785                 :       4870 :                 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
    4786                 :            :               /* Allocatable and pointer arrays need to processed
    4787                 :            :                  explicitly.  */
    4788                 :      22268 :               else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
    4789                 :      22262 :                        || (sym->ts.type == BT_CLASS
    4790                 :          0 :                            && CLASS_DATA (sym)->attr.class_pointer)
    4791                 :      22262 :                        || array_attr->allocatable)
    4792                 :            :                 {
    4793                 :          6 :                   if (TREE_STATIC (sym->backend_decl))
    4794                 :            :                     {
    4795                 :          6 :                       gfc_save_backend_locus (&loc);
    4796                 :          6 :                       gfc_set_backend_locus (&sym->declared_at);
    4797                 :          6 :                       gfc_trans_static_array_pointer (sym);
    4798                 :          6 :                       gfc_restore_backend_locus (&loc);
    4799                 :            :                     }
    4800                 :            :                   else
    4801                 :            :                     {
    4802                 :          0 :                       seen_trans_deferred_array = true;
    4803                 :          0 :                       gfc_trans_deferred_array (sym, block);
    4804                 :            :                     }
    4805                 :            :                 }
    4806                 :      22544 :               else if (sym->attr.codimension
    4807                 :      22262 :                        && TREE_STATIC (sym->backend_decl))
    4808                 :            :                 {
    4809                 :        282 :                   gfc_init_block (&tmpblock);
    4810                 :        282 :                   gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
    4811                 :            :                                             &tmpblock, sym);
    4812                 :        282 :                   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
    4813                 :            :                                         NULL_TREE);
    4814                 :        282 :                   continue;
    4815                 :            :                 }
    4816                 :            :               else
    4817                 :            :                 {
    4818                 :      21980 :                   gfc_save_backend_locus (&loc);
    4819                 :      21980 :                   gfc_set_backend_locus (&sym->declared_at);
    4820                 :            : 
    4821                 :      21980 :                   if (alloc_comp_or_fini)
    4822                 :            :                     {
    4823                 :        335 :                       seen_trans_deferred_array = true;
    4824                 :        335 :                       gfc_trans_deferred_array (sym, block);
    4825                 :            :                     }
    4826                 :      21645 :                   else if (sym->ts.type == BT_DERIVED
    4827                 :       1181 :                              && sym->value
    4828                 :            :                              && !sym->attr.data
    4829                 :        374 :                              && sym->attr.save == SAVE_NONE)
    4830                 :            :                     {
    4831                 :        220 :                       gfc_start_block (&tmpblock);
    4832                 :        220 :                       gfc_init_default_dt (sym, &tmpblock, false);
    4833                 :        220 :                       gfc_add_init_cleanup (block,
    4834                 :            :                                             gfc_finish_block (&tmpblock),
    4835                 :            :                                             NULL_TREE);
    4836                 :            :                     }
    4837                 :            : 
    4838                 :      21980 :                   gfc_trans_auto_array_allocation (sym->backend_decl,
    4839                 :            :                                                    sym, block);
    4840                 :      21980 :                   gfc_restore_backend_locus (&loc);
    4841                 :            :                 }
    4842                 :            :               break;
    4843                 :            : 
    4844                 :       1085 :             case AS_ASSUMED_SIZE:
    4845                 :            :               /* Must be a dummy parameter.  */
    4846                 :       1085 :               gcc_assert (sym->attr.dummy || as->cp_was_assumed);
    4847                 :            : 
    4848                 :            :               /* We should always pass assumed size arrays the g77 way.  */
    4849                 :       1085 :               if (sym->attr.dummy)
    4850                 :       1085 :                 gfc_trans_g77_array (sym, block);
    4851                 :            :               break;
    4852                 :            : 
    4853                 :       3542 :             case AS_ASSUMED_SHAPE:
    4854                 :            :               /* Must be a dummy parameter.  */
    4855                 :       3542 :               gcc_assert (sym->attr.dummy);
    4856                 :            : 
    4857                 :       3542 :               gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
    4858                 :       3542 :               break;
    4859                 :            : 
    4860                 :       6672 :             case AS_ASSUMED_RANK:
    4861                 :       6672 :             case AS_DEFERRED:
    4862                 :       6672 :               seen_trans_deferred_array = true;
    4863                 :       6672 :               gfc_trans_deferred_array (sym, block);
    4864                 :       6672 :               if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
    4865                 :        251 :                   && sym->attr.result)
    4866                 :            :                 {
    4867                 :         20 :                   gfc_start_block (&init);
    4868                 :         20 :                   gfc_save_backend_locus (&loc);
    4869                 :         20 :                   gfc_set_backend_locus (&sym->declared_at);
    4870                 :         20 :                   tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
    4871                 :         20 :                   gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
    4872                 :            :                 }
    4873                 :            :               break;
    4874                 :            : 
    4875                 :          0 :             default:
    4876                 :          0 :               gcc_unreachable ();
    4877                 :            :             }
    4878                 :      38155 :           if (alloc_comp_or_fini && !seen_trans_deferred_array)
    4879                 :        153 :             gfc_trans_deferred_array (sym, block);
    4880                 :            :         }
    4881                 :       7320 :       else if ((!sym->attr.dummy || sym->ts.deferred)
    4882                 :       7126 :                 && (sym->ts.type == BT_CLASS
    4883                 :       1666 :                 && CLASS_DATA (sym)->attr.class_pointer))
    4884                 :        156 :         continue;
    4885                 :       7164 :       else if ((!sym->attr.dummy || sym->ts.deferred)
    4886                 :       6970 :                 && (sym->attr.allocatable
    4887                 :       6970 :                     || (sym->attr.pointer && sym->attr.result)
    4888                 :       5409 :                     || (sym->ts.type == BT_CLASS
    4889                 :       1510 :                         && CLASS_DATA (sym)->attr.allocatable)))
    4890                 :            :         {
    4891                 :       3071 :           if (!sym->attr.save && flag_max_stack_var_size != 0)
    4892                 :            :             {
    4893                 :       3016 :               tree descriptor = NULL_TREE;
    4894                 :            : 
    4895                 :       3016 :               gfc_save_backend_locus (&loc);
    4896                 :       3016 :               gfc_set_backend_locus (&sym->declared_at);
    4897                 :       3016 :               gfc_start_block (&init);
    4898                 :            : 
    4899                 :       3016 :               if (sym->ts.type == BT_CHARACTER
    4900                 :            :                   && sym->attr.allocatable
    4901                 :        612 :                   && !sym->attr.dimension
    4902                 :        594 :                   && sym->ts.u.cl && sym->ts.u.cl->length
    4903                 :         69 :                   && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
    4904                 :          7 :                 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
    4905                 :            : 
    4906                 :       3016 :               if (!sym->attr.pointer)
    4907                 :            :                 {
    4908                 :            :                   /* Nullify and automatic deallocation of allocatable
    4909                 :            :                      scalars.  */
    4910                 :       2965 :                   e = gfc_lval_expr_from_sym (sym);
    4911                 :       2965 :                   if (sym->ts.type == BT_CLASS)
    4912                 :       1510 :                     gfc_add_data_component (e);
    4913                 :            : 
    4914                 :       2965 :                   gfc_init_se (&se, NULL);
    4915                 :       2965 :                   if (sym->ts.type != BT_CLASS
    4916                 :       1510 :                       || sym->ts.u.derived->attr.dimension
    4917                 :       1510 :                       || sym->ts.u.derived->attr.codimension)
    4918                 :            :                     {
    4919                 :       1455 :                       se.want_pointer = 1;
    4920                 :       1455 :                       gfc_conv_expr (&se, e);
    4921                 :            :                     }
    4922                 :       1510 :                   else if (sym->ts.type == BT_CLASS
    4923                 :       1510 :                            && !CLASS_DATA (sym)->attr.dimension
    4924                 :       1510 :                            && !CLASS_DATA (sym)->attr.codimension)
    4925                 :            :                     {
    4926                 :        889 :                       se.want_pointer = 1;
    4927                 :        889 :                       gfc_conv_expr (&se, e);
    4928                 :            :                     }
    4929                 :            :                   else
    4930                 :            :                     {
    4931                 :        621 :                       se.descriptor_only = 1;
    4932                 :        621 :                       gfc_conv_expr (&se, e);
    4933                 :        621 :                       descriptor = se.expr;
    4934                 :        621 :                       se.expr = gfc_conv_descriptor_data_addr (se.expr);
    4935                 :        621 :                       se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
    4936                 :            :                     }
    4937                 :       2965 :                   gfc_free_expr (e);
    4938                 :            : 
    4939                 :       2965 :                   if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
    4940                 :            :                     {
    4941                 :            :                       /* Nullify when entering the scope.  */
    4942                 :      14825 :                       tmp = fold_build2_loc (input_location, MODIFY_EXPR,
    4943                 :       2965 :                                              TREE_TYPE (se.expr), se.expr,
    4944                 :       2965 :                                              fold_convert (TREE_TYPE (se.expr),
    4945                 :            :                                                            null_pointer_node));
    4946                 :       2965 :                       if (sym->attr.optional)
    4947                 :            :                         {
    4948                 :          0 :                           tree present = gfc_conv_expr_present (sym);
    4949                 :          0 :                           tmp = build3_loc (input_location, COND_EXPR,
    4950                 :            :                                             void_type_node, present, tmp,
    4951                 :            :                                             build_empty_stmt (input_location));
    4952                 :            :                         }
    4953                 :       2965 :                       gfc_add_expr_to_block (&init, tmp);
    4954                 :            :                     }
    4955                 :            :                 }
    4956                 :            : 
    4957                 :       3016 :               if ((sym->attr.dummy || sym->attr.result)
    4958                 :        312 :                     && sym->ts.type == BT_CHARACTER
    4959                 :         82 :                     && sym->ts.deferred
    4960                 :         82 :                     && sym->ts.u.cl->passed_length)
    4961                 :         82 :                 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
    4962                 :            :               else
    4963                 :            :                 {
    4964                 :       2934 :                   gfc_restore_backend_locus (&loc);
    4965                 :       2934 :                   tmp = NULL_TREE;
    4966                 :            :                 }
    4967                 :            : 
    4968                 :            :               /* Deallocate when leaving the scope. Nullifying is not
    4969                 :            :                  needed.  */
    4970                 :       3016 :               if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
    4971                 :       2704 :                   && !sym->ns->proc_name->attr.is_main_program)
    4972                 :            :                 {
    4973                 :        902 :                   if (sym->ts.type == BT_CLASS
    4974                 :        303 :                       && CLASS_DATA (sym)->attr.codimension)
    4975                 :          5 :                     tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
    4976                 :            :                                                       NULL_TREE, NULL_TREE,
    4977                 :            :                                                       NULL_TREE, true, NULL,
    4978                 :            :                                                       GFC_CAF_COARRAY_ANALYZE);
    4979                 :            :                   else
    4980                 :            :                     {
    4981                 :        897 :                       gfc_expr *expr = gfc_lval_expr_from_sym (sym);
    4982                 :        897 :                       tmp = gfc_deallocate_scalar_with_status (se.expr,
    4983                 :            :                                                                NULL_TREE,
    4984                 :            :                                                                NULL_TREE,
    4985                 :            :                                                                true, expr,
    4986                 :            :                                                                sym->ts);
    4987                 :        897 :                       gfc_free_expr (expr);
    4988                 :            :                     }
    4989                 :            :                 }
    4990                 :            : 
    4991                 :       3016 :               if (sym->ts.type == BT_CLASS)
    4992                 :            :                 {
    4993                 :            :                   /* Initialize _vptr to declared type.  */
    4994                 :       1510 :                   gfc_symbol *vtab;
    4995                 :       1510 :                   tree rhs;
    4996                 :            : 
    4997                 :       1510 :                   gfc_save_backend_locus (&loc);
    4998                 :       1510 :                   gfc_set_backend_locus (&sym->declared_at);
    4999                 :       1510 :                   e = gfc_lval_expr_from_sym (sym);
    5000                 :       1510 :                   gfc_add_vptr_component (e);
    5001                 :       1510 :                   gfc_init_se (&se, NULL);
    5002                 :       1510 :                   se.want_pointer = 1;
    5003                 :       1510 :                   gfc_conv_expr (&se, e);
    5004                 :       1510 :                   gfc_free_expr (e);
    5005                 :       1510 :                   if (UNLIMITED_POLY (sym))
    5006                 :        158 :                     rhs = build_int_cst (TREE_TYPE (se.expr), 0);
    5007                 :            :                   else
    5008                 :            :                     {
    5009                 :       1352 :                       vtab = gfc_find_derived_vtab (sym->ts.u.derived);
    5010                 :       1352 :                       rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
    5011                 :            :                                                 gfc_get_symbol_decl (vtab));
    5012                 :            :                     }
    5013                 :       1510 :                   gfc_add_modify (&init, se.expr, rhs);
    5014                 :       1510 :                   gfc_restore_backend_locus (&loc);
    5015                 :            :                 }
    5016                 :            : 
    5017                 :       3016 :               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
    5018                 :            :             }
    5019                 :            :         }
    5020                 :       4093 :       else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
    5021                 :            :         {
    5022                 :        104 :           tree tmp = NULL;
    5023                 :        104 :           stmtblock_t init;
    5024                 :            : 
    5025                 :            :           /* If we get to here, all that should be left are pointers.  */
    5026                 :        104 :           gcc_assert (sym->attr.pointer);
    5027                 :            : 
    5028                 :        104 :           if (sym->attr.dummy)
    5029                 :            :             {
    5030                 :          0 :               gfc_start_block (&init);
    5031                 :          0 :               gfc_save_backend_locus (&loc);
    5032                 :          0 :               gfc_set_backend_locus (&sym->declared_at);
    5033                 :          0 :               tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
    5034                 :          0 :               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
    5035                 :        104 :             }
    5036                 :            :         }
    5037                 :       3989 :       else if (sym->ts.deferred)
    5038                 :          0 :         gfc_fatal_error ("Deferred type parameter not yet supported");
    5039                 :       3989 :       else if (alloc_comp_or_fini)
    5040                 :       2962 :         gfc_trans_deferred_array (sym, block);
    5041                 :       1027 :       else if (sym->ts.type == BT_CHARACTER)
    5042                 :            :         {
    5043                 :        617 :           gfc_save_backend_locus (&loc);
    5044                 :        617 :           gfc_set_backend_locus (&sym->declared_at);
    5045                 :        617 :           if (sym->attr.dummy || sym->attr.result)
    5046                 :        290 :             gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
    5047                 :            :           else
    5048                 :        327 :             gfc_trans_auto_character_variable (sym, block);
    5049                 :        617 :           gfc_restore_backend_locus (&loc);
    5050                 :            :         }
    5051                 :        410 :       else if (sym->attr.assign)
    5052                 :            :         {
    5053                 :         96 :           gfc_save_backend_locus (&loc);
    5054                 :         96 :           gfc_set_backend_locus (&sym->declared_at);
    5055                 :         96 :           gfc_trans_assign_aux_var (sym, block);
    5056                 :         96 :           gfc_restore_backend_locus (&loc);
    5057                 :            :         }
    5058                 :        314 :       else if (sym->ts.type == BT_DERIVED
    5059                 :        314 :                  && sym->value
    5060                 :            :                  && !sym->attr.data
    5061                 :        265 :                  && sym->attr.save == SAVE_NONE)
    5062                 :            :         {
    5063                 :        247 :           gfc_start_block (&tmpblock);
    5064                 :        247 :           gfc_init_default_dt (sym, &tmpblock, false);
    5065                 :        247 :           gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
    5066                 :            :                                 NULL_TREE);
    5067                 :            :         }
    5068                 :         67 :       else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
    5069                 :          0 :         gcc_unreachable ();
    5070                 :            : 
    5071                 :            :       /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
    5072                 :            :          as ISO Fortran Interop descriptors. These have to be converted to
    5073                 :            :          gfortran descriptors and back again.  This has to be done here so that
    5074                 :            :          the conversion occurs at the start of the init block.  */
    5075                 :      45358 :       if (is_CFI_desc (sym, NULL))
    5076                 :         45 :         convert_CFI_desc (block, sym);
    5077                 :            :     }
    5078                 :            : 
    5079                 :      64772 :   gfc_init_block (&tmpblock);
    5080                 :            : 
    5081                 :     128836 :   for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
    5082                 :            :     {
    5083                 :      64064 :       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
    5084                 :       4299 :           && f->sym->ts.u.cl->backend_decl)
    5085                 :            :         {
    5086                 :       4299 :           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
    5087                 :       3160 :             gfc_trans_vla_type_sizes (f->sym, &tmpblock);
    5088                 :            :         }
    5089                 :            :     }
    5090                 :            : 
    5091                 :      67124 :   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
    5092                 :      66008 :       && current_fake_result_decl != NULL)
    5093                 :            :     {
    5094                 :        745 :       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
    5095                 :        745 :       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
    5096                 :         69 :         gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
    5097                 :            :     }
    5098                 :            : 
    5099                 :      64772 :   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
    5100                 :      64772 : }
    5101                 :            : 
    5102                 :            : 
    5103                 :            : struct module_hasher : ggc_ptr_hash<module_htab_entry>
    5104                 :            : {
    5105                 :            :   typedef const char *compare_type;
    5106                 :            : 
    5107                 :      20134 :   static hashval_t hash (module_htab_entry *s)
    5108                 :            :   {
    5109                 :      20134 :     return htab_hash_string (s->name);
    5110                 :            :   }
    5111                 :            : 
    5112                 :            :   static bool
    5113                 :      23577 :   equal (module_htab_entry *a, const char *b)
    5114                 :            :   {
    5115                 :      23577 :     return !strcmp (a->name, b);
    5116                 :            :   }
    5117                 :            : };
    5118                 :            : 
    5119                 :            : static GTY (()) hash_table<module_hasher> *module_htab;
    5120                 :            : 
    5121                 :            : /* Hash and equality functions for module_htab's decls.  */
    5122                 :            : 
    5123                 :            : hashval_t
    5124                 :      93187 : module_decl_hasher::hash (tree t)
    5125                 :            : {
    5126                 :      93187 :   const_tree n = DECL_NAME (t);
    5127                 :      93187 :   if (n == NULL_TREE)
    5128                 :      15406 :     n = TYPE_NAME (TREE_TYPE (t));
    5129                 :      93187 :   return htab_hash_string (IDENTIFIER_POINTER (n));
    5130                 :            : }
    5131                 :            : 
    5132                 :            : bool
    5133                 :      99553 : module_decl_hasher::equal (tree t1, const char *x2)
    5134                 :            : {
    5135                 :      99553 :   const_tree n1 = DECL_NAME (t1);
    5136                 :      99553 :   if (n1 == NULL_TREE)
    5137                 :      16293 :     n1 = TYPE_NAME (TREE_TYPE (t1));
    5138                 :      99553 :   return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
    5139                 :            : }
    5140                 :            : 
    5141                 :            : struct module_htab_entry *
    5142                 :      21595 : gfc_find_module (const char *name)
    5143                 :            : {
    5144                 :      21595 :   if (! module_htab)
    5145                 :       5793 :     module_htab = hash_table<module_hasher>::create_ggc (10);
    5146                 :            : 
    5147                 :      21595 :   module_htab_entry **slot
    5148                 :      21595 :     = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
    5149                 :      21595 :   if (*slot == NULL)
    5150                 :            :     {
    5151                 :       7471 :       module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
    5152                 :            : 
    5153                 :       7471 :       entry->name = gfc_get_string ("%s", name);
    5154                 :       7471 :       entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
    5155                 :       7471 :       *slot = entry;
    5156                 :            :     }
    5157                 :      21595 :   return *slot;
    5158                 :            : }
    5159                 :            : 
    5160                 :            : void
    5161                 :      32465 : gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
    5162                 :            : {
    5163                 :      32465 :   const char *name;
    5164                 :            : 
    5165                 :      32465 :   if (DECL_NAME (decl))
    5166                 :      27779 :     name = IDENTIFIER_POINTER (DECL_NAME (decl));
    5167                 :            :   else
    5168                 :            :     {
    5169                 :       4686 :       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
    5170                 :       4686 :       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
    5171                 :            :     }
    5172                 :      32465 :   tree *slot
    5173                 :      32465 :     = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
    5174                 :            :                                          INSERT);
    5175                 :      32465 :   if (*slot == NULL)
    5176                 :      32447 :     *slot = decl;
    5177                 :      32465 : }
    5178                 :            : 
    5179                 :            : 
    5180                 :            : /* Generate debugging symbols for namelists. This function must come after
    5181                 :            :    generate_local_decl to ensure that the variables in the namelist are
    5182                 :            :    already declared.  */
    5183                 :            : 
    5184                 :            : static tree
    5185                 :        661 : generate_namelist_decl (gfc_symbol * sym)
    5186                 :            : {
    5187                 :        661 :   gfc_namelist *nml;
    5188                 :        661 :   tree decl;
    5189                 :        661 :   vec<constructor_elt, va_gc> *nml_decls = NULL;
    5190                 :            : 
    5191                 :        661 :   gcc_assert (sym->attr.flavor == FL_NAMELIST);
    5192                 :       2525 :   for (nml = sym->namelist; nml; nml = nml->next)
    5193                 :            :     {
    5194                 :       1864 :       if (nml->sym->backend_decl == NULL_TREE)
    5195                 :            :         {
    5196                 :        180 :           nml->sym->attr.referenced = 1;
    5197                 :        180 :           nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
    5198                 :            :         }
    5199                 :       1864 :       DECL_IGNORED_P (nml->sym->backend_decl) = 0;
    5200                 :       1864 :       CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
    5201                 :            :     }
    5202                 :            : 
    5203                 :        661 :   decl = make_node (NAMELIST_DECL);
    5204                 :        661 :   TREE_TYPE (decl) = void_type_node;
    5205                 :        661 :   NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
    5206                 :        661 :   DECL_NAME (decl) = get_identifier (sym->name);
    5207                 :        661 :   return decl;
    5208                 :            : }
    5209                 :            : 
    5210                 :            : 
    5211                 :            : /* Output an initialized decl for a module variable.  */
    5212                 :            : 
    5213                 :            : static void
    5214                 :      86796 : gfc_create_module_variable (gfc_symbol * sym)
    5215                 :            : {
    5216                 :      86796 :   tree decl;
    5217                 :            : 
    5218                 :            :   /* Module functions with alternate entries are dealt with later and
    5219                 :            :      would get caught by the next condition.  */
    5220                 :      86796 :   if (sym->attr.entry)
    5221                 :            :     return;
    5222                 :            : 
    5223                 :            :   /* Make sure we convert the types of the derived types from iso_c_binding
    5224                 :            :      into (void *).  */
    5225                 :      86415 :   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
    5226                 :      18335 :       && sym->ts.type == BT_DERIVED)
    5227                 :        852 :     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
    5228                 :            : 
    5229                 :      86415 :   if (gfc_fl_struct (sym->attr.flavor)
    5230                 :      14931 :       && sym->backend_decl
    5231                 :       4687 :       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
    5232                 :            :     {
    5233                 :       4686 :       decl = sym->backend_decl;
    5234                 :       4686 :       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
    5235                 :            : 
    5236                 :       4686 :       if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
    5237                 :            :         {
    5238                 :       4602 :           gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
    5239                 :            :                       || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
    5240                 :       4602 :           gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
    5241                 :            :                       || DECL_CONTEXT (TYPE_STUB_DECL (decl))
    5242                 :            :                            == sym->ns->proc_name->backend_decl);
    5243                 :            :         }
    5244                 :       4686 :       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
    5245                 :       4686 :       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
    5246                 :       4686 :       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
    5247                 :            :     }
    5248                 :            : 
    5249                 :            :   /* Only output variables, procedure pointers and array valued,
    5250                 :            :      or derived type, parameters.  */
    5251                 :      86415 :   if (sym->attr.flavor != FL_VARIABLE
    5252                 :      73160 :         && !(sym->attr.flavor == FL_PARAMETER
    5253                 :      21618 :                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
    5254                 :      72375 :         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
    5255                 :            :     return;
    5256                 :            : 
    5257                 :      14104 :   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
    5258                 :            :     {
    5259                 :        417 :       decl = sym->backend_decl;
    5260                 :        417 :       gcc_assert (DECL_FILE_SCOPE_P (decl));
    5261                 :        417 :       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
    5262                 :        417 :       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
    5263                 :        417 :       gfc_module_add_decl (cur_module, decl);
    5264                 :            :     }
    5265                 :            : 
    5266                 :            :   /* Don't generate variables from other modules. Variables from
    5267                 :            :      COMMONs and Cray pointees will already have been generated.  */
    5268                 :      14104 :   if (sym->attr.use_assoc || sym->attr.used_in_submodule
    5269                 :      14104 :       || sym->attr.in_common || sym->attr.cray_pointee)
    5270                 :            :     return;
    5271                 :            : 
    5272                 :            :   /* Equivalenced variables arrive here after creation.  */
    5273                 :      11463 :   if (sym->backend_decl
    5274                 :        462 :       && (sym->equiv_built || sym->attr.in_equivalence))
    5275                 :            :     return;
    5276                 :            : 
    5277                 :      11384 :   if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
    5278                 :          0 :     gfc_internal_error ("backend decl for module variable %qs already exists",
    5279                 :            :                         sym->name);
    5280                 :            : 
    5281                 :      11384 :   if (sym->module && !sym->attr.result && !sym->attr.dummy
    5282                 :      11384 :       && (sym->attr.access == ACCESS_UNKNOWN
    5283                 :       2172 :           && (sym->ns->default_access == ACCESS_PRIVATE
    5284                 :       2107 :               || (sym->ns->default_access == ACCESS_UNKNOWN
    5285                 :       2093 :                   && flag_module_private))))
    5286                 :         66 :     sym->attr.access = ACCESS_PRIVATE;
    5287                 :            : 
    5288                 :      11384 :   if (warn_unused_variable && !sym->attr.referenced
    5289                 :        205 :       && sym->attr.access == ACCESS_PRIVATE)
    5290                 :          3 :     gfc_warning (OPT_Wunused_value,
    5291                 :            :                  "Unused PRIVATE module variable %qs declared at %L",
    5292                 :            :                  sym->name, &sym->declared_at);
    5293                 :            : 
    5294                 :            :   /* We always want module variables to be created.  */
    5295                 :      11384 :   sym->attr.referenced = 1;
    5296                 :            :   /* Create the decl.  */
    5297                 :      11384 :   decl = gfc_get_symbol_decl (sym);
    5298                 :            : 
    5299                 :            :   /* Create the variable.  */
    5300                 :      11384 :   pushdecl (decl);
    5301                 :      11384 :   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
    5302                 :            :               || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
    5303                 :            :                   && sym->fn_result_spec));
    5304                 :      11384 :   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
    5305                 :      11384 :   rest_of_decl_compilation (decl, 1, 0);
    5306                 :      11384 :   gfc_module_add_decl (cur_module, decl);
    5307                 :            : 
    5308                 :            :   /* Also add length of strings.  */
    5309                 :      11384 :   if (sym->ts.type == BT_CHARACTER)
    5310                 :            :     {
    5311                 :        292 :       tree length;
    5312                 :            : 
    5313                 :        292 :       length = sym->ts.u.cl->backend_decl;
    5314                 :        292 :       gcc_assert (length || sym->attr.proc_pointer);
    5315                 :        292 :       if (length && !INTEGER_CST_P (length))
    5316                 :            :         {
    5317                 :         18 :           pushdecl (length);
    5318                 :         18 :           rest_of_decl_compilation (length, 1, 0);
    5319                 :            :         }
    5320                 :            :     }
    5321                 :            : 
    5322                 :      11384 :   if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
    5323                 :         18 :       && sym->attr.referenced && !sym->attr.use_assoc)
    5324                 :         18 :     has_coarray_vars = true;
    5325                 :            : }
    5326                 :            : 
    5327                 :            : /* Emit debug information for USE statements.  */
    5328                 :            : 
    5329                 :            : static void
    5330                 :      64526 : gfc_trans_use_stmts (gfc_namespace * ns)
    5331                 :            : {
    5332                 :      64526 :   gfc_use_list *use_stmt;
    5333                 :      72689 :   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
    5334                 :            :     {
    5335                 :       8163 :       struct module_htab_entry *entry
    5336                 :       8163 :         = gfc_find_module (use_stmt->module_name);
    5337                 :       8163 :       gfc_use_rename *rent;
    5338                 :            : 
    5339                 :       8163 :       if (entry->namespace_decl == NULL)
    5340                 :            :         {
    5341                 :        755 :           entry->namespace_decl
    5342                 :        755 :             = build_decl (input_location,
    5343                 :            :                           NAMESPACE_DECL,
    5344                 :            :                           get_identifier (use_stmt->module_name),
    5345                 :            :                           void_type_node);
    5346                 :        755 :           DECL_EXTERNAL (entry->namespace_decl) = 1;
    5347                 :            :         }
    5348                 :       8163 :       gfc_set_backend_locus (&use_stmt->where);
    5349                 :       8163 :       if (!use_stmt->only_flag)
    5350                 :       6924 :         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
    5351                 :            :                                                  NULL_TREE,
    5352                 :       6924 :                                                  ns->proc_name->backend_decl,
    5353                 :            :                                                  false, false);
    5354                 :      10151 :       for (rent = use_stmt->rename; rent; rent = rent->next)
    5355                 :            :         {
    5356                 :       1988 :           tree decl, local_name;
    5357                 :            : 
    5358                 :       1988 :           if (rent->op != INTRINSIC_NONE)
    5359                 :         85 :             continue;
    5360                 :            : 
    5361                 :       1903 :                                                  hashval_t hash = htab_hash_string (rent->use_name);
    5362                 :       1903 :           tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
    5363                 :            :                                                           INSERT);
    5364                 :       1903 :           if (*slot == NULL)
    5365                 :            :             {
    5366                 :       1020 :               gfc_symtree *st;
    5367                 :            : 
    5368                 :       1020 :               st = gfc_find_symtree (ns->sym_root,
    5369                 :       1020 :                                      rent->local_name[0]
    5370                 :            :                                      ? rent->local_name : rent->use_name);
    5371                 :            : 
    5372                 :            :               /* The following can happen if a derived type is renamed.  */
    5373                 :       1020 :               if (!st)
    5374                 :            :                 {
    5375                 :          0 :                   char *name;
    5376                 :          0 :                   name = xstrdup (rent->local_name[0]
    5377                 :            :                                   ? rent->local_name : rent->use_name);
    5378                 :          0 :                   name[0] = (char) TOUPPER ((unsigned char) name[0]);
    5379                 :          0 :                   st = gfc_find_symtree (ns->sym_root, name);
    5380                 :          0 :                   free (name);
    5381                 :          0 :                   gcc_assert (st);
    5382                 :            :                 }
    5383                 :            : 
    5384                 :            :               /* Sometimes, generic interfaces wind up being over-ruled by a
    5385                 :            :                  local symbol (see PR41062).  */
    5386                 :       1020 :               if (!st->n.sym->attr.use_assoc)
    5387                 :          8 :                 continue;
    5388                 :            : 
    5389                 :       1012 :               if (st->n.sym->backend_decl
    5390                 :        142 :                   && DECL_P (st->n.sym->backend_decl)
    5391                 :        142 :                   && st->n.sym->module
    5392                 :        142 :                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
    5393                 :            :                 {
    5394                 :        134 :                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
    5395                 :            :                               || !VAR_P (st->n.sym->backend_decl));
    5396                 :        134 :                   decl = copy_node (st->n.sym->backend_decl);
    5397                 :        134 :                   DECL_CONTEXT (decl) = entry->namespace_decl;
    5398                 :        134 :                   DECL_EXTERNAL (decl) = 1;
    5399                 :        134 :                   DECL_IGNORED_P (decl) = 0;
    5400                 :        134 :                   DECL_INITIAL (decl) = NULL_TREE;
    5401                 :            :                 }
    5402                 :        878 :               else if (st->n.sym->attr.flavor == FL_NAMELIST
    5403                 :          0 :                        && st->n.sym->attr.use_only
    5404                 :          0 :                        && st->n.sym->module
    5405                 :          0 :                        && strcmp (st->n.sym->module, use_stmt->module_name)
    5406                 :            :                           == 0)
    5407                 :            :                 {
    5408                 :          0 :                   decl = generate_namelist_decl (st->n.sym);
    5409                 :          0 :                   DECL_CONTEXT (decl) = entry->namespace_decl;
    5410                 :          0 :                   DECL_EXTERNAL (decl) = 1;
    5411                 :          0 :                   DECL_IGNORED_P (decl) = 0;
    5412                 :          0 :                   DECL_INITIAL (decl) = NULL_TREE;
    5413                 :            :                 }
    5414                 :            :               else
    5415                 :            :                 {
    5416                 :        878 :                   *slot = error_mark_node;
    5417                 :        878 :                   entry->decls->clear_slot (slot);
    5418                 :        878 :                   continue;
    5419                 :            :                 }
    5420                 :        134 :               *slot = decl;
    5421                 :            :             }
    5422                 :       1017 :           decl = (tree) *slot;
    5423                 :       1017 :           if (rent->local_name[0])
    5424                 :        186 :             local_name = get_identifier (rent->local_name);
    5425                 :            :           else
    5426                 :            :             local_name = NULL_TREE;
    5427                 :       1017 :           gfc_set_backend_locus (&rent->where);
    5428                 :       1017 :           (*debug_hooks->imported_module_or_decl) (decl, local_name,
    5429                 :       1017 :                                                    ns->proc_name->backend_decl,
    5430                 :       1017 :                                                    !use_stmt->only_flag,
    5431                 :            :                                                    false);
    5432                 :            :         }
    5433                 :            :     }
    5434                 :      64526 : }
    5435                 :            : 
    5436                 :            : 
    5437                 :            : /* Return true if expr is a constant initializer that gfc_conv_initializer
    5438                 :            :    will handle.  */
    5439                 :            : 
    5440                 :            : static bool
    5441                 :      13933 : check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
    5442                 :            :                             bool pointer)
    5443                 :            : {
    5444                 :      13933 :   gfc_constructor *c;
    5445                 :      13933 :   gfc_component *cm;
    5446                 :            : 
    5447                 :      13933 :   if (pointer)
    5448                 :            :     return true;
    5449                 :      13925 :   else if (array)
    5450                 :            :     {
    5451                 :       1629 :       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
    5452                 :            :         return true;
    5453                 :       1525 :       else if (expr->expr_type == EXPR_STRUCTURE)
    5454                 :         13 :         return check_constant_initializer (expr, ts, false, false);
    5455                 :       1512 :       else if (expr->expr_type != EXPR_ARRAY)
    5456                 :            :         return false;
    5457                 :       1512 :       for (c = gfc_constructor_first (expr->value.constructor);
    5458                 :     238288 :            c; c = gfc_constructor_next (c))
    5459                 :            :         {
    5460                 :     118388 :           if (c->iterator)
    5461                 :            :             return false;
    5462                 :     118388 :           if (c->expr->expr_type == EXPR_STRUCTURE)
    5463                 :            :             {
    5464                 :         98 :               if (!check_constant_initializer (c->expr, ts, false, false))
    5465                 :            :                 return false;
    5466                 :            :             }
    5467                 :     118290 :           else if (c->expr->expr_type != EXPR_CONSTANT)
    5468                 :            :             return false;
    5469                 :            :         }
    5470                 :            :       return true;
    5471                 :            :     }
    5472                 :      12296 :   else switch (ts->type)
    5473                 :            :     {
    5474                 :        323 :     case_bt_struct:
    5475                 :        323 :       if (expr->expr_type != EXPR_STRUCTURE)
    5476                 :            :         return false;
    5477                 :        323 :       cm = expr->ts.u.derived->components;
    5478                 :        323 :       for (c = gfc_constructor_first (expr->value.constructor);
    5479                 :       1103 :            c; c = gfc_constructor_next (c), cm = cm->next)
    5480                 :            :         {
    5481                 :        875 :           if (!c->expr || cm->attr.allocatable)
    5482                 :        369 :             continue;
    5483                 :        506 :           if (!check_constant_initializer (c->expr, &cm->ts,
    5484                 :            :                                            cm->attr.dimension,
    5485                 :            :                                            cm->attr.pointer))
    5486                 :            :             return false;
    5487                 :            :         }
    5488                 :            :       return true;
    5489                 :      11973 :     default:
    5490                 :      11973 :       return expr->expr_type == EXPR_CONSTANT;
    5491                 :            :     }
    5492                 :            : }
    5493                 :            : 
    5494                 :            : /* Emit debug info for parameters and unreferenced variables with
    5495                 :            :    initializers.  */
    5496                 :            : 
    5497                 :            : static void
    5498                 :     630851 : gfc_emit_parameter_debug_info (gfc_symbol *sym)
    5499                 :            : {
    5500                 :     630851 :   tree decl;
    5501                 :            : 
    5502                 :     630851 :   if (sym->attr.flavor != FL_PARAMETER
    5503                 :     549419 :       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
    5504                 :            :     return;
    5505                 :            : 
    5506                 :     106896 :   if (sym->backend_decl != NULL
    5507                 :      95973 :       || sym->value == NULL
    5508                 :            :       || sym->attr.use_assoc
    5509                 :            :       || sym->attr.dummy
    5510                 :            :       || sym->attr.result
    5511                 :            :       || sym->attr.function
    5512                 :            :       || sym->attr.intrinsic
    5513                 :            :       || sym->attr.pointer
    5514                 :      84965 :       || sym->attr.allocatable
    5515                 :      13357 :       || sym->attr.cray_pointee
    5516                 :            :       || sym->attr.threadprivate
    5517                 :            :       || sym->attr.is_bind_c
    5518                 :            :       || sym->attr.subref_array_pointer
    5519                 :      13357 :       || sym->attr.assign)
    5520                 :            :     return;
    5521                 :            : 
    5522                 :      13357 :   if (sym->ts.type == BT_CHARACTER)
    5523                 :            :     {
    5524                 :       1150 :       gfc_conv_const_charlen (sym->ts.u.cl);
    5525                 :       1150 :       if (sym->ts.u.cl->backend_decl == NULL
    5526                 :       1150 :           || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
    5527                 :            :         return;
    5528                 :            :     }
    5529                 :      12207 :   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
    5530                 :            :     return;
    5531                 :            : 
    5532                 :      13316 :   if (sym->as)
    5533                 :            :     {
    5534                 :       1564 :       int n;
    5535                 :            : 
    5536                 :       1564 :       if (sym->as->type != AS_EXPLICIT)
    5537                 :            :         return;
    5538                 :       3619 :       for (n = 0; n < sym->as->rank; n++)
    5539                 :       2055 :         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
    5540                 :       2055 :             || sym->as->upper[n] == NULL
    5541                 :       2055 :             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
    5542                 :            :           return;
    5543                 :            :     }
    5544                 :            : 
    5545                 :      13316 :   if (!check_constant_initializer (sym->value, &sym->ts,
    5546                 :      13316 :                                    sym->attr.dimension, false))
    5547                 :            :     return;
    5548                 :            : 
    5549                 :      13195 :   if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
    5550                 :            :     return;
    5551                 :            : 
    5552                 :            :   /* Create the decl for the variable or constant.  */
    5553                 :      26390 :   decl = build_decl (input_location,
    5554                 :      13195 :                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
    5555                 :            :                      gfc_sym_identifier (sym), gfc_sym_type (sym));
    5556                 :      13195 :   if (sym->attr.flavor == FL_PARAMETER)
    5557                 :      12984 :     TREE_READONLY (decl) = 1;
    5558                 :      13195 :   gfc_set_decl_location (decl, &sym->declared_at);
    5559                 :      13195 :   if (sym->attr.dimension)
    5560                 :       1564 :     GFC_DECL_PACKED_ARRAY (decl) = 1;
    5561                 :      13195 :   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
    5562                 :      13195 :   TREE_STATIC (decl) = 1;
    5563                 :      13195 :   TREE_USED (decl) = 1;
    5564                 :      13195 :   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
    5565                 :       1331 :     TREE_PUBLIC (decl) = 1;
    5566                 :      13195 :   DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
    5567                 :      13195 :                                               TREE_TYPE (decl),
    5568                 :            :                                               sym->attr.dimension,
    5569                 :      13195 :                                               false, false);
    5570                 :      13195 :   debug_hooks->early_global_decl (decl);
    5571                 :            : }
    5572                 :            : 
    5573                 :            : 
    5574                 :            : static void
    5575                 :       2423 : generate_coarray_sym_init (gfc_symbol *sym)
    5576                 :            : {
    5577                 :       2423 :   tree tmp, size, decl, token, desc;
    5578                 :       2423 :   bool is_lock_type, is_event_type;
    5579                 :       2423 :   int reg_type;
    5580                 :       2423 :   gfc_se se;
    5581                 :       2423 :   symbol_attribute attr;
    5582                 :            : 
    5583                 :       2423 :   if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
    5584                 :       2423 :       || sym->attr.use_assoc || !sym->attr.referenced
    5585                 :        259 :       || sym->attr.select_type_temporary)
    5586                 :       2204 :     return;
    5587                 :            : 
    5588                 :        219 :   decl = sym->backend_decl;
    5589                 :        219 :   TREE_USED(decl) = 1;
    5590                 :        219 :   gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
    5591                 :            : 
    5592                 :        438 :   is_lock_type = sym->ts.type == BT_DERIVED
    5593                 :        112 :                  && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    5594                 :        219 :                  && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
    5595                 :            : 
    5596                 :        438 :   is_event_type = sym->ts.type == BT_DERIVED
    5597                 :        112 :                   && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    5598                 :        219 :                   && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
    5599                 :            : 
    5600                 :            :   /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
    5601                 :            :      to make sure the variable is not optimized away.  */
    5602                 :        219 :   DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
    5603                 :            : 
    5604                 :            :   /* For lock types, we pass the array size as only the library knows the
    5605                 :            :      size of the variable.  */
    5606                 :        219 :   if (is_lock_type || is_event_type)
    5607                 :         13 :     size = gfc_index_one_node;
    5608                 :            :   else
    5609                 :        206 :     size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
    5610                 :            : 
    5611                 :            :   /* Ensure that we do not have size=0 for zero-sized arrays.  */
    5612                 :        219 :   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
    5613                 :            :                           fold_convert (size_type_node, size),
    5614                 :        219 :                           build_int_cst (size_type_node, 1));
    5615                 :            : 
    5616                 :        219 :   if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
    5617                 :            :     {
    5618                 :         65 :       tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
    5619                 :         65 :       size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
    5620                 :            :                               fold_convert (size_type_node, tmp), size);
    5621                 :            :     }
    5622                 :            : 
    5623                 :        219 :   gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
    5624                 :        219 :   token = gfc_build_addr_expr (ppvoid_type_node,
    5625                 :        219 :                                GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
    5626                 :        219 :   if (is_lock_type)
    5627                 :          9 :     reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
    5628                 :        210 :   else if (is_event_type)
    5629                 :            :     reg_type = GFC_CAF_EVENT_STATIC;
    5630                 :            :   else
    5631                 :        206 :     reg_type = GFC_CAF_COARRAY_STATIC;
    5632                 :            : 
    5633                 :            :   /* Compile the symbol attribute.  */
    5634                 :        219 :   if (sym->ts.type == BT_CLASS)
    5635                 :            :     {
    5636                 :          0 :       attr = CLASS_DATA (sym)->attr;
    5637                 :            :       /* The pointer attribute is always set on classes, overwrite it with the
    5638                 :            :          class_pointer attribute, which denotes the pointer for classes.  */
    5639                 :          0 :       attr.pointer = attr.class_pointer;
    5640                 :            :     }
    5641                 :            :   else
    5642                 :        219 :     attr = sym->attr;
    5643                 :        219 :   gfc_init_se (&se, NULL);
    5644                 :        219 :   desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
    5645                 :        219 :   gfc_add_block_to_block (&caf_init_block, &se.pre);
    5646                 :            : 
    5647                 :        219 :   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
    5648                 :            :                              build_int_cst (integer_type_node, reg_type),
    5649                 :            :                              token, gfc_build_addr_expr (pvoid_type_node, desc),
    5650                 :            :                              null_pointer_node, /* stat.  */
    5651                 :            :                              null_pointer_node, /* errgmsg.  */
    5652                 :            :                              build_zero_cst (size_type_node)); /* errmsg_len.  */
    5653                 :        219 :   gfc_add_expr_to_block (&caf_init_block, tmp);
    5654                 :        219 :   gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
    5655                 :            :                                           gfc_conv_descriptor_data_get (desc)));
    5656                 :            : 
    5657                 :            :   /* Handle "static" initializer.  */
    5658                 :        219 :   if (sym->value)
    5659                 :            :     {
    5660                 :         82 :       if (sym->value->expr_type == EXPR_ARRAY)
    5661                 :            :         {
    5662                 :          6 :           gfc_constructor *c, *cnext;
    5663                 :            : 
    5664                 :            :           /* Test if the array has more than one element.  */
    5665                 :          6 :           c = gfc_constructor_first (sym->value->value.constructor);
    5666                 :          6 :           gcc_assert (c);  /* Empty constructor should not happen here.  */
    5667                 :          6 :           cnext = gfc_constructor_next (c);
    5668                 :            : 
    5669                 :          6 :           if (cnext)
    5670                 :            :             {
    5671                 :            :               /* An EXPR_ARRAY with a rank > 1 here has to come from a
    5672                 :            :                  DATA statement.  Set its rank here as not to confuse
    5673                 :            :                  the following steps.   */
    5674                 :          5 :               sym->value->rank = 1;
    5675                 :            :             }
    5676                 :            :           else
    5677                 :            :             {
    5678                 :            :               /* There is only a single value in the constructor, use
    5679                 :            :                  it directly for the assignment.  */
    5680                 :          1 :               gfc_expr *new_expr;
    5681                 :          1 :               new_expr = gfc_copy_expr (c->expr);
    5682                 :          1 :               gfc_free_expr (sym->value);
    5683                 :          1 :               sym->value = new_expr;
    5684                 :            :             }
    5685                 :            :         }
    5686                 :            : 
    5687                 :         82 :       sym->attr.pointer = 1;
    5688                 :         82 :       tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
    5689                 :            :                                   true, false);
    5690                 :         82 :       sym->attr.pointer = 0;
    5691                 :         82 :       gfc_add_expr_to_block (&caf_init_block, tmp);
    5692                 :            :     }
    5693                 :        137 :   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
    5694                 :            :     {
    5695                 :         27 :       tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
    5696                 :            :                                     ? sym->as->rank : 0,
    5697                 :            :                                     GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
    5698                 :         27 :       gfc_add_expr_to_block (&caf_init_block, tmp);
    5699                 :            :     }
    5700                 :            : }
    5701                 :            : 
    5702                 :            : 
    5703                 :            : /* Generate constructor function to initialize static, nonallocatable
    5704                 :            :    coarrays.  */
    5705                 :            : 
    5706                 :            : static void
    5707                 :        168 : generate_coarray_init (gfc_namespace * ns __attribute((unused)))
    5708                 :            : {
    5709                 :        168 :   tree fndecl, tmp, decl, save_fn_decl;
    5710                 :            : 
    5711                 :        168 :   save_fn_decl = current_function_decl;
    5712                 :        168 :   push_function_context ();
    5713                 :            : 
    5714                 :        168 :   tmp = build_function_type_list (void_type_node, NULL_TREE);
    5715                 :        168 :   fndecl = build_decl (input_location, FUNCTION_DECL,
    5716                 :            :                        create_tmp_var_name ("_caf_init"), tmp);
    5717                 :            : 
    5718                 :        168 :   DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
    5719                 :        168 :   SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
    5720                 :            : 
    5721                 :        168 :   decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
    5722                 :        168 :   DECL_ARTIFICIAL (decl) = 1;
    5723                 :        168 :   DECL_IGNORED_P (decl) = 1;
    5724                 :        168 :   DECL_CONTEXT (decl) = fndecl;
    5725                 :        168 :   DECL_RESULT (fndecl) = decl;
    5726                 :            : 
    5727                 :        168 :   pushdecl (fndecl);
    5728                 :        168 :   current_function_decl = fndecl;
    5729                 :        168 :   announce_function (fndecl);
    5730                 :            : 
    5731                 :        168 :   rest_of_decl_compilation (fndecl, 0, 0);
    5732                 :        168 :   make_decl_rtl (fndecl);
    5733                 :        168 :   allocate_struct_function (fndecl, false);
    5734                 :            : 
    5735                 :        168 :   pushlevel ();
    5736                 :        168 :   gfc_init_block (&caf_init_block);
    5737                 :            : 
    5738                 :        168 :   gfc_traverse_ns (ns, generate_coarray_sym_init);
    5739                 :            : 
    5740                 :        168 :   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
    5741                 :        168 :   decl = getdecls ();
    5742                 :            : 
    5743                 :        168 :   poplevel (1, 1);
    5744                 :        168 :   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
    5745                 :            : 
    5746                 :        336 :   DECL_SAVED_TREE (fndecl)
    5747                 :        168 :     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
    5748                 :            :                 DECL_INITIAL (fndecl));
    5749                 :        168 :   dump_function (TDI_original, fndecl);
    5750                 :            : 
    5751                 :        168 :   cfun->function_end_locus = input_location;
    5752                 :        168 :   set_cfun (NULL);
    5753                 :            : 
    5754                 :        168 :   if (decl_function_context (fndecl))
    5755                 :        163 :     (void) cgraph_node::create (fndecl);
    5756                 :            :   else
    5757                 :          5 :     cgraph_node::finalize_function (fndecl, true);
    5758                 :            : 
    5759                 :        168 :   pop_function_context ();
    5760                 :        168 :   current_function_decl = save_fn_decl;
    5761                 :        168 : }
    5762                 :            : 
    5763                 :            : 
    5764                 :            : static void
    5765                 :      86796 : create_module_nml_decl (gfc_symbol *sym)
    5766                 :            : {
    5767                 :      86796 :   if (sym->attr.flavor == FL_NAMELIST)
    5768                 :            :     {
    5769                 :         43 :       tree decl = generate_namelist_decl (sym);
    5770                 :         43 :       pushdecl (decl);
    5771                 :         43 :       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
    5772                 :         43 :       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
    5773                 :         43 :       rest_of_decl_compilation (decl, 1, 0);
    5774                 :         43 :       gfc_module_add_decl (cur_module, decl);
    5775                 :            :     }
    5776                 :      86796 : }
    5777                 :            : 
    5778                 :            : 
    5779                 :            : /* Generate all the required code for module variables.  */
    5780                 :            : 
    5781                 :            : void
    5782                 :       6716 : gfc_generate_module_vars (gfc_namespace * ns)
    5783                 :            : {
    5784                 :       6716 :   module_namespace = ns;
    5785                 :       6716 :   cur_module = gfc_find_module (ns->proc_name->name);
    5786                 :            : 
    5787                 :            :   /* Check if the frontend left the namespace in a reasonable state.  */
    5788                 :       6716 :   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
    5789                 :            : 
    5790                 :            :   /* Generate COMMON blocks.  */
    5791                 :       6716 :   gfc_trans_common (ns);
    5792                 :            : 
    5793                 :       6716 :   has_coarray_vars = false;
    5794                 :            : 
    5795                 :            :   /* Create decls for all the module variables.  */
    5796                 :       6716 :   gfc_traverse_ns (ns, gfc_create_module_variable);
    5797                 :       6716 :   gfc_traverse_ns (ns, create_module_nml_decl);
    5798                 :            : 
    5799                 :       6716 :   if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
    5800                 :          5 :     generate_coarray_init (ns);
    5801                 :            : 
    5802                 :       6716 :   cur_module = NULL;
    5803                 :            : 
    5804                 :       6716 :   gfc_trans_use_stmts (ns);
    5805                 :       6716 :   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
    5806                 :       6716 : }
    5807                 :            : 
    5808                 :            : 
    5809                 :            : static void
    5810                 :      57810 : gfc_generate_contained_functions (gfc_namespace * parent)
    5811                 :            : {
    5812                 :      57810 :   gfc_namespace *ns;
    5813                 :            : 
    5814                 :            :   /* We create all the prototypes before generating any code.  */
    5815                 :      70023 :   for (ns = parent->contained; ns; ns = ns->sibling)
    5816                 :            :     {
    5817                 :            :       /* Skip namespaces from used modules.  */
    5818                 :      12213 :       if (ns->parent != parent)
    5819                 :          0 :         continue;
    5820                 :            : 
    5821                 :      12213 :       gfc_create_function_decl (ns, false);
    5822                 :            :     }
    5823                 :            : 
    5824                 :      70023 :   for (ns = parent->contained; ns; ns = ns->sibling)
    5825                 :            :     {
    5826                 :            :       /* Skip namespaces from used modules.  */
    5827                 :      12213 :       if (ns->parent != parent)
    5828                 :          0 :         continue;
    5829                 :            : 
    5830                 :      12213 :       gfc_generate_function_code (ns);
    5831                 :            :     }
    5832                 :      57810 : }
    5833                 :            : 
    5834                 :            : 
    5835                 :            : /* Drill down through expressions for the array specification bounds and
    5836                 :            :    character length calling generate_local_decl for all those variables
    5837                 :            :    that have not already been declared.  */
    5838                 :            : 
    5839                 :            : static void
    5840                 :            : generate_local_decl (gfc_symbol *);
    5841                 :            : 
    5842                 :            : /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
    5843                 :            : 
    5844                 :            : static bool
    5845                 :      79967 : expr_decls (gfc_expr *e, gfc_symbol *sym,
    5846                 :            :             int *f ATTRIBUTE_UNUSED)
    5847                 :            : {
    5848                 :      79967 :   if (e->expr_type != EXPR_VARIABLE
    5849                 :       5469 :             || sym == e->symtree->n.sym
    5850                 :       5456 :             || e->symtree->n.sym->mark
    5851                 :        585 :             || e->symtree->n.sym->ns != sym->ns)
    5852                 :            :         return false;
    5853                 :            : 
    5854                 :        585 :   generate_local_decl (e->symtree->n.sym);
    5855                 :        585 :   return false;
    5856                 :            : }
    5857                 :            : 
    5858                 :            : static void
    5859                 :      94084 : generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
    5860                 :            : {
    5861                 :          0 :   gfc_traverse_expr (e, sym, expr_decls, 0);
    5862                 :        844 : }
    5863                 :            : 
    5864                 :            : 
    5865                 :            : /* Check for dependencies in the character length and array spec.  */
    5866                 :            : 
    5867                 :            : static void
    5868                 :     131523 : generate_dependency_declarations (gfc_symbol *sym)
    5869                 :            : {
    5870                 :     131523 :   int i;
    5871                 :            : 
    5872                 :     131523 :   if (sym->ts.type == BT_CHARACTER
    5873                 :      13237 :       && sym->ts.u.cl
    5874                 :      13237 :       && sym->ts.u.cl->length
    5875                 :      11891 :       && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
    5876                 :        844 :     generate_expr_decls (sym, sym->ts.u.cl->length);
    5877                 :            : 
    5878                 :     131523 :   if (sym->as && sym->as->rank)
    5879                 :            :     {
    5880                 :      81466 :       for (i = 0; i < sym->as->rank; i++)
    5881                 :            :         {
    5882                 :      46620 :           generate_expr_decls (sym, sym->as->lower[i]);
    5883                 :      46620 :           generate_expr_decls (sym, sym->as->upper[i]);
    5884                 :            :         }
    5885                 :            :     }
    5886                 :     131523 : }
    5887                 :            : 
    5888                 :            : 
    5889                 :            : /* Generate decls for all local variables.  We do this to ensure correct
    5890                 :            :    handling of expressions which only appear in the specification of
    5891                 :            :    other functions.  */
    5892                 :            : 
    5893                 :            : static void
    5894                 :     558823 : generate_local_decl (gfc_symbol * sym)
    5895                 :            : {
    5896                 :     558823 :   if (sym->attr.flavor == FL_VARIABLE)
    5897                 :            :     {
    5898                 :     195287 :       if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
    5899                 :        399 :           && sym->attr.referenced && !sym->attr.use_assoc)
    5900                 :        355 :         has_coarray_vars = true;
    5901                 :            : 
    5902                 :     195287 :       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
    5903                 :     131523 :         generate_dependency_declarations (sym);
    5904                 :            : 
    5905                 :     195287 :       if (sym->attr.referenced)
    5906                 :     173160 :         gfc_get_symbol_decl (sym);
    5907                 :            : 
    5908                 :            :       /* Warnings for unused dummy arguments.  */
    5909                 :      22127 :       else if (sym->attr.dummy && !sym->attr.in_namelist)
    5910                 :            :         {
    5911                 :            :           /* INTENT(out) dummy arguments are likely meant to be set.  */
    5912                 :       5742 :           if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
    5913                 :            :             {
    5914                 :          9 :               if (sym->ts.type != BT_DERIVED)
    5915                 :          6 :                 gfc_warning (OPT_Wunused_dummy_argument,
    5916                 :            :                              "Dummy argument %qs at %L was declared "
    5917                 :            :                              "INTENT(OUT) but was not set",  sym->name,
    5918                 :            :                              &sym->declared_at);
    5919                 :          3 :               else if (!gfc_has_default_initializer (sym->ts.u.derived)
    5920                 :          3 :                        && !sym->ts.u.derived->attr.zero_comp)
    5921                 :          1 :                 gfc_warning (OPT_Wunused_dummy_argument,
    5922                 :            :                              "Derived-type dummy argument %qs at %L was "
    5923                 :            :                              "declared INTENT(OUT) but was not set and "
    5924                 :            :                              "does not have a default initializer",
    5925                 :            :                              sym->name, &sym->declared_at);
    5926                 :          9 :               if (sym->backend_decl != NULL_TREE)
    5927                 :          9 :                 TREE_NO_WARNING(sym->backend_decl) = 1;
    5928                 :            :             }
    5929                 :       5733 :           else if (warn_unused_dummy_argument)
    5930                 :            :             {
    5931                 :          6 :               if (!sym->attr.artificial)
    5932                 :          4 :                 gfc_warning (OPT_Wunused_dummy_argument,
    5933                 :            :                              "Unused dummy argument %qs at %L", sym->name,
    5934                 :            :                              &sym->declared_at);
    5935                 :            : 
    5936                 :          6 :               if (sym->backend_decl != NULL_TREE)
    5937                 :          4 :                 TREE_NO_WARNING(sym->backend_decl) = 1;
    5938                 :            :             }
    5939                 :            :         }
    5940                 :            : 
    5941                 :            :       /* Warn for unused variables, but not if they're inside a common
    5942                 :            :          block or a namelist.  */
    5943                 :      16385 :       else if (warn_unused_variable
    5944                 :         10 :                && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
    5945                 :            :         {
    5946                 :          8 :           if (sym->attr.use_only)
    5947                 :            :             {
    5948                 :          1 :               gfc_warning (OPT_Wunused_variable,
    5949                 :            :                            "Unused module variable %qs which has been "
    5950                 :            :                            "explicitly imported at %L", sym->name,
    5951                 :            :                            &sym->declared_at);
    5952                 :          1 :               if (sym->backend_decl != NULL_TREE)
    5953                 :          0 :                 TREE_NO_WARNING(sym->backend_decl) = 1;
    5954                 :            :             }
    5955                 :          7 :           else if (!sym->attr.use_assoc)
    5956                 :            :             {
    5957                 :            :               /* Corner case: the symbol may be an entry point.  At this point,
    5958                 :            :                  it may appear to be an unused variable.  Suppress warning.  */
    5959                 :          6 :               bool enter = false;
    5960                 :          6 :               gfc_entry_list *el;
    5961                 :            : 
    5962                 :         12 :               for (el = sym->ns->entries; el; el=el->next)
    5963                 :          6 :                 if (strcmp(sym->name, el->sym->name) == 0)
    5964                 :          2 :                   enter = true;
    5965                 :            : 
    5966                 :          6 :               if (!enter)
    5967                 :          4 :                 gfc_warning (OPT_Wunused_variable,
    5968                 :            :                              "Unused variable %qs declared at %L",
    5969                 :            :                              sym->name, &sym->declared_at);
    5970                 :          6 :               if (sym->backend_decl != NULL_TREE)
    5971                 :          0 :                 TREE_NO_WARNING(sym->backend_decl) = 1;
    5972                 :            :             }
    5973                 :            :         }
    5974                 :            : 
    5975                 :            :       /* For variable length CHARACTER parameters, the PARM_DECL already
    5976                 :            :          references the length variable, so force gfc_get_symbol_decl
    5977                 :            :          even when not referenced.  If optimize > 0, it will be optimized
    5978                 :            :          away anyway.  But do this only after emitting -Wunused-parameter
    5979                 :            :          warning if requested.  */
    5980                 :     195287 :       if (sym->attr.dummy && !sym->attr.referenced
    5981                 :       5745 :             && sym->ts.type == BT_CHARACTER
    5982                 :        583 :             && sym->ts.u.cl->backend_decl != NULL
    5983                 :        580 :             && VAR_P (sym->ts.u.cl->backend_decl))
    5984                 :            :         {
    5985                 :          6 :           sym->attr.referenced = 1;
    5986                 :          6 :           gfc_get_symbol_decl (sym);
    5987                 :            :         }
    5988                 :            : 
    5989                 :            :       /* INTENT(out) dummy arguments and result variables with allocatable
    5990                 :            :          components are reset by default and need to be set referenced to
    5991                 :            :          generate the code for nullification and automatic lengths.  */
    5992                 :     195287 :       if (!sym->attr.referenced
    5993                 :      22121 :             && sym->ts.type == BT_DERIVED
    5994                 :       9824 :             && sym->ts.u.derived->attr.alloc_comp
    5995                 :       1091 :             && !sym->attr.pointer
    5996                 :       1091 :             && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
    5997                 :       1071 :                   ||
    5998                 :       1071 :                 (sym->attr.result && sym != sym->result)))
    5999                 :            :         {
    6000                 :         20 :           sym->attr.referenced = 1;
    6001                 :         20 :           gfc_get_symbol_decl (sym);
    6002                 :            :         }
    6003                 :            : 
    6004                 :            :       /* Check for dependencies in the array specification and string
    6005                 :            :         length, adding the necessary declarations to the function.  We
    6006                 :            :         mark the symbol now, as well as in traverse_ns, to prevent
    6007                 :            :         getting stuck in a circular dependency.  */
    6008                 :     195287 :       sym->mark = 1;
    6009                 :            :     }
    6010                 :     363536 :   else if (sym->attr.flavor == FL_PARAMETER)
    6011                 :            :     {
    6012                 :      59880 :       if (warn_unused_parameter
    6013                 :          5 :            && !sym->attr.referenced)
    6014                 :            :         {
    6015                 :          5 :            if (!sym->attr.use_assoc)
    6016                 :          4 :              gfc_warning (OPT_Wunused_parameter,
    6017                 :            :                           "Unused parameter %qs declared at %L", sym->name,
    6018                 :            :                           &sym->declared_at);
    6019                 :          1 :            else if (sym->attr.use_only)
    6020                 :          1 :              gfc_warning (OPT_Wunused_parameter,
    6021                 :            :                           "Unused parameter %qs which has been explicitly "
    6022                 :            :                           "imported at %L", sym->name, &sym->declared_at);
    6023                 :            :         }
    6024                 :            : 
    6025                 :      59880 :       if (sym->ns && sym->ns->construct_entities)
    6026                 :            :         {
    6027                 :            :           /* Construction of the intrinsic modules within a BLOCK
    6028                 :            :              construct, where ONLY and RENAMED entities are included,
    6029                 :            :              seems to be bogus.  This is a workaround that can be removed
    6030                 :            :              if someone ever takes on the task to creating full-fledge
    6031                 :            :              modules.  See PR 69455.  */
    6032                 :         64 :           if (sym->attr.referenced
    6033                 :         64 :               && sym->from_intmod != INTMOD_ISO_C_BINDING
    6034                 :         40 :               && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV)
    6035                 :         16 :             gfc_get_symbol_decl (sym);
    6036                 :         64 :           sym->mark = 1;
    6037                 :            :         }
    6038                 :            :     }
    6039                 :     303656 :   else if (sym->attr.flavor == FL_PROCEDURE)
    6040                 :            :     {
    6041                 :            :       /* TODO: move to the appropriate place in resolve.c.  */
    6042                 :     242480 :       if (warn_return_type > 0
    6043                 :       3856 :           && sym->attr.function
    6044                 :       2952 :           && sym->result
    6045                 :       2852 :           && sym != sym->result
    6046                 :        423 :           && !sym->result->attr.referenced
    6047                 :         36 :           && !sym->attr.use_assoc
    6048                 :         23 :           && sym->attr.if_source != IFSRC_IFBODY)
    6049                 :            :         {
    6050                 :         23 :           gfc_warning (OPT_Wreturn_type,
    6051                 :            :                        "Return value %qs of function %qs declared at "
    6052                 :            :                        "%L not set", sym->result->name, sym->name,
    6053                 :            :                         &sym->result->declared_at);
    6054                 :            : 
    6055                 :            :           /* Prevents "Unused variable" warning for RESULT variables.  */
    6056                 :         23 :           sym->result->mark = 1;
    6057                 :            :         }
    6058                 :            :     }
    6059                 :            : 
    6060                 :     558823 :   if (sym->attr.dummy == 1)
    6061                 :            :     {
    6062                 :            :       /* Modify the tree type for scalar character dummy arguments of bind(c)
    6063                 :            :          procedures if they are passed by value.  The tree type for them will
    6064                 :            :          be promoted to INTEGER_TYPE for the middle end, which appears to be
    6065                 :            :          what C would do with characters passed by-value.  The value attribute
    6066                 :            :          implies the dummy is a scalar.  */
    6067                 :      64043 :       if (sym->attr.value == 1 && sym->backend_decl != NULL
    6068                 :       4498 :           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
    6069                 :         66 :           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
    6070                 :         55 :         gfc_conv_scalar_char_value (sym, NULL, NULL);
    6071                 :            : 
    6072                 :            :       /* Unused procedure passed as dummy argument.  */
    6073                 :      64043 :       if (sym->attr.flavor == FL_PROCEDURE)
    6074                 :            :         {
    6075                 :        819 :           if (!sym->attr.referenced)
    6076                 :            :             {
    6077                 :         53 :               if (warn_unused_dummy_argument)
    6078                 :          2 :                 gfc_warning (OPT_Wunused_dummy_argument,
    6079                 :            :                              "Unused dummy argument %qs at %L", sym->name,
    6080                 :            :                              &sym->declared_at);
    6081                 :            :             }
    6082                 :            : 
    6083                 :            :           /* Silence bogus "unused parameter" warnings from the
    6084                 :            :              middle end.  */
    6085                 :        819 :           if (sym->backend_decl != NULL_TREE)
    6086                 :        819 :                 TREE_NO_WARNING (sym->backend_decl) = 1;
    6087                 :            :         }
    6088                 :            :     }
    6089                 :            : 
    6090                 :            :   /* Make sure we convert the types of the derived types from iso_c_binding
    6091                 :            :      into (void *).  */
    6092                 :     558823 :   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
    6093                 :      23133 :       && sym->ts.type == BT_DERIVED)
    6094                 :       1069 :     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
    6095                 :     558823 : }
    6096                 :            : 
    6097                 :            : 
    6098                 :            : static void
    6099                 :     558830 : generate_local_nml_decl (gfc_symbol * sym)
    6100                 :            : {
    6101                 :     558830 :   if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
    6102                 :            :     {
    6103                 :        618 :       tree decl = generate_namelist_decl (sym);
    6104                 :        618 :       pushdecl (decl);
    6105                 :            :     }
    6106                 :     558830 : }
    6107                 :            : 
    6108                 :            : 
    6109                 :            : static void
    6110                 :      64772 : generate_local_vars (gfc_namespace * ns)
    6111                 :            : {
    6112                 :          0 :   gfc_traverse_ns (ns, generate_local_decl);
    6113                 :      64772 :   gfc_traverse_ns (ns, generate_local_nml_decl);
    6114                 :          0 : }
    6115                 :            : 
    6116                 :            : 
    6117                 :            : /* Generate a switch statement to jump to the correct entry point.  Also
    6118                 :            :    creates the label decls for the entry points.  */
    6119                 :            : 
    6120                 :            : static tree
    6121                 :        574 : gfc_trans_entry_master_switch (gfc_entry_list * el)
    6122                 :            : {
    6123                 :        574 :   stmtblock_t block;
    6124                 :        574 :   tree label;
    6125                 :        574 :   tree tmp;
    6126                 :        574 :   tree val;
    6127                 :            : 
    6128                 :        574 :   gfc_init_block (&block);
    6129                 :       1799 :   for (; el; el = el->next)
    6130                 :            :     {
    6131                 :            :       /* Add the case label.  */
    6132                 :       1225 :       label = gfc_build_label_decl (NULL_TREE);
    6133                 :       1225 :       val = build_int_cst (gfc_array_index_type, el->id);
    6134                 :       1225 :       tmp = build_case_label (val, NULL_TREE, label);
    6135                 :       1225 :       gfc_add_expr_to_block (&block, tmp);
    6136                 :            : 
    6137                 :            :       /* And jump to the actual entry point.  */
    6138                 :       1225 :       label = gfc_build_label_decl (NULL_TREE);
    6139                 :       1225 :       tmp = build1_v (GOTO_EXPR, label);
    6140                 :       1225 :       gfc_add_expr_to_block (&block, tmp);
    6141                 :            : 
    6142                 :            :       /* Save the label decl.  */
    6143                 :       1225 :       el->label = label;
    6144                 :            :     }
    6145                 :        574 :   tmp = gfc_finish_block (&block);
    6146                 :            :   /* The first argument selects the entry point.  */
    6147                 :        574 :   val = DECL_ARGUMENTS (current_function_decl);
    6148                 :        574 :   tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp);
    6149                 :        574 :   return tmp;
    6150                 :            : }
    6151                 :            : 
    6152                 :            : 
    6153                 :            : /* Add code to string lengths of actual arguments passed to a function against
    6154                 :            :    the expected lengths of the dummy arguments.  */
    6155                 :            : 
    6156                 :            : static void
    6157                 :       2076 : add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
    6158                 :            : {
    6159                 :       2076 :   gfc_formal_arglist *formal;
    6160                 :            : 
    6161                 :       4026 :   for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
    6162                 :       1950 :     if (formal->sym && formal->sym->ts.type == BT_CHARACTER
    6163                 :        349 :         && !formal->sym->ts.deferred)
    6164                 :            :       {
    6165                 :        348 :         enum tree_code comparison;
    6166                 :        348 :         tree cond;
    6167                 :        348 :         tree argname;
    6168                 :        348 :         gfc_symbol *fsym;
    6169                 :        348 :         gfc_charlen *cl;
    6170                 :        348 :         const char *message;
    6171                 :            : 
    6172                 :        348 :         fsym = formal->sym;
    6173                 :        348 :         cl = fsym->ts.u.cl;
    6174                 :            : 
    6175                 :        348 :         gcc_assert (cl);
    6176                 :        348 :         gcc_assert (cl->passed_length != NULL_TREE);
    6177                 :        348 :         gcc_assert (cl->backend_decl != NULL_TREE);
    6178                 :            : 
    6179                 :            :         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
    6180                 :            :            string lengths must match exactly.  Otherwise, it is only required
    6181                 :            :            that the actual string length is *at least* the expected one.
    6182                 :            :            Sequence association allows for a mismatch of the string length
    6183                 :            :            if the actual argument is (part of) an array, but only if the
    6184                 :            :            dummy argument is an array. (See "Sequence association" in
    6185                 :            :            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
    6186                 :        348 :         if (fsym->attr.pointer || fsym->attr.allocatable
    6187                 :        336 :             || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
    6188                 :         33 :                              || fsym->as->type == AS_ASSUMED_RANK)))
    6189                 :            :           {
    6190                 :         27 :             comparison = NE_EXPR;
    6191                 :         27 :             message = _("Actual string length does not match the declared one"
    6192                 :            :                         " for dummy argument '%s' (%ld/%ld)");
    6193                 :            :           }
    6194                 :        321 :         else if (fsym->as && fsym->as->rank != 0)
    6195                 :         33 :           continue;
    6196                 :            :         else
    6197                 :            :           {
    6198                 :        288 :             comparison = LT_EXPR;
    6199                 :        288 :             message = _("Actual string length is shorter than the declared one"
    6200                 :            :                         " for dummy argument '%s' (%ld/%ld)");
    6201                 :            :           }
    6202                 :            : 
    6203                 :            :         /* Build the condition.  For optional arguments, an actual length
    6204                 :            :            of 0 is also acceptable if the associated string is NULL, which
    6205                 :            :            means the argument was not passed.  */
    6206                 :        315 :         cond = fold_build2_loc (input_location, comparison, logical_type_node,
    6207                 :            :                                 cl->passed_length, cl->backend_decl);
    6208                 :        315 :         if (fsym->attr.optional)
    6209                 :            :           {
    6210                 :         45 :             tree not_absent;
    6211                 :         45 :             tree not_0length;
    6212                 :         45 :             tree absent_failed;
    6213                 :            : 
    6214                 :         45 :             not_0length = fold_build2_loc (input_location, NE_EXPR,
    6215                 :            :                                            logical_type_node,
    6216                 :            :                                            cl->passed_length,
    6217                 :            :                                            build_zero_cst
    6218                 :         45 :                                            (TREE_TYPE (cl->passed_length)));
    6219                 :            :             /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
    6220                 :         45 :             fsym->attr.referenced = 1;
    6221                 :         45 :             not_absent = gfc_conv_expr_present (fsym);
    6222                 :            : 
    6223                 :         45 :             absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    6224                 :            :                                              logical_type_node, not_0length,
    6225                 :            :                                              not_absent);
    6226                 :            : 
    6227                 :         45 :             cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    6228                 :            :                                     logical_type_node, cond, absent_failed);
    6229                 :            :           }
    6230                 :            : 
    6231                 :            :         /* Build the runtime check.  */
    6232                 :        315 :         argname = gfc_build_cstring_const (fsym->name);
    6233                 :        315 :         argname = gfc_build_addr_expr (pchar_type_node, argname);
    6234                 :        315 :         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
    6235                 :            :                                  message, argname,
    6236                 :            :                                  fold_convert (long_integer_type_node,
    6237                 :            :                                                cl->passed_length),
    6238                 :            :                                  fold_convert (long_integer_type_node,
    6239                 :            :                                                cl->backend_decl));
    6240                 :            :       }
    6241                 :       2076 : }
    6242                 :            : 
    6243                 :            : 
    6244                 :            : static void
    6245                 :      21186 : create_main_function (tree fndecl)
    6246                 :            : {
    6247                 :      21186 :   tree old_context;
    6248                 :      21186 :   tree ftn_main;
    6249                 :      21186 :   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
    6250                 :      21186 :   stmtblock_t body;
    6251                 :            : 
    6252                 :      21186 :   old_context = current_function_decl;
    6253                 :            : 
    6254                 :      21186 :   if (old_context)
    6255                 :            :     {
    6256                 :          0 :       push_function_context ();
    6257                 :          0 :       saved_parent_function_decls = saved_function_decls;
    6258                 :          0 :       saved_function_decls = NULL_TREE;
    6259                 :            :     }
    6260                 :            : 
    6261                 :            :   /* main() function must be declared with global scope.  */
    6262                 :      21186 :   gcc_assert (current_function_decl == NULL_TREE);
    6263                 :            : 
    6264                 :            :   /* Declare the function.  */
    6265                 :      21186 :   tmp =  build_function_type_list (integer_type_node, integer_type_node,
    6266                 :            :                                    build_pointer_type (pchar_type_node),
    6267                 :            :                                    NULL_TREE);
    6268                 :      21186 :   main_identifier_node = get_identifier ("main");
    6269                 :      21186 :   ftn_main = build_decl (input_location, FUNCTION_DECL,
    6270                 :            :                          main_identifier_node, tmp);
    6271                 :      21186 :   DECL_EXTERNAL (ftn_main) = 0;
    6272                 :      21186 :   TREE_PUBLIC (ftn_main) = 1;
    6273                 :      21186 :   TREE_STATIC (ftn_main) = 1;
    6274                 :      42372 :   DECL_ATTRIBUTES (ftn_main)
    6275                 :      21186 :       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
    6276                 :            : 
    6277                 :            :   /* Setup the result declaration (for "return 0").  */
    6278                 :      21186 :   result_decl = build_decl (input_location,
    6279                 :            :                             RESULT_DECL, NULL_TREE, integer_type_node);
    6280                 :      21186 :   DECL_ARTIFICIAL (result_decl) = 1;
    6281                 :      21186 :   DECL_IGNORED_P (result_decl) = 1;
    6282                 :      21186 :   DECL_CONTEXT (result_decl) = ftn_main;
    6283                 :      21186 :   DECL_RESULT (ftn_main) = result_decl;
    6284                 :            : 
    6285                 :      21186 :   pushdecl (ftn_main);
    6286                 :            : 
    6287                 :            :   /* Get the arguments.  */
    6288                 :            : 
    6289                 :      21186 :   arglist = NULL_TREE;
    6290                 :      21186 :   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
    6291                 :            : 
    6292                 :      21186 :   tmp = TREE_VALUE (typelist);
    6293                 :      21186 :   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
    6294                 :      21186 :   DECL_CONTEXT (argc) = ftn_main;
    6295                 :      21186 :   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
    6296                 :      21186 :   TREE_READONLY (argc) = 1;
    6297                 :      21186 :   gfc_finish_decl (argc);
    6298                 :      21186 :   arglist = chainon (arglist, argc);
    6299                 :            : 
    6300                 :      21186 :   typelist = TREE_CHAIN (typelist);
    6301                 :      21186 :   tmp = TREE_VALUE (typelist);
    6302                 :      21186 :   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
    6303                 :      21186 :   DECL_CONTEXT (argv) = ftn_main;
    6304                 :      21186 :   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
    6305                 :      21186 :   TREE_READONLY (argv) = 1;
    6306                 :      21186 :   DECL_BY_REFERENCE (argv) = 1;
    6307                 :      21186 :   gfc_finish_decl (argv);
    6308                 :      21186 :   arglist = chainon (arglist, argv);
    6309                 :            : 
    6310                 :      21186 :   DECL_ARGUMENTS (ftn_main) = arglist;
    6311                 :      21186 :   current_function_decl = ftn_main;
    6312                 :      21186 :   announce_function (ftn_main);
    6313                 :            : 
    6314                 :      21186 :   rest_of_decl_compilation (ftn_main, 1, 0);
    6315                 :      21186 :   make_decl_rtl (ftn_main);
    6316                 :      21186 :   allocate_struct_function (ftn_main, false);
    6317                 :      21186 :   pushlevel ();
    6318                 :            : 
    6319                 :      21186 :   gfc_init_block (&body);
    6320                 :            : 
    6321                 :            :   /* Call some libgfortran initialization routines, call then MAIN__().  */
    6322                 :            : 
    6323                 :            :   /* Call _gfortran_caf_init (*argc, ***argv).  */
    6324                 :      21186 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    6325                 :            :     {
    6326                 :        234 :       tree pint_type, pppchar_type;
    6327                 :        234 :       pint_type = build_pointer_type (integer_type_node);
    6328                 :        234 :       pppchar_type
    6329                 :        234 :         = build_pointer_type (build_pointer_type (pchar_type_node));
    6330                 :            : 
    6331                 :        234 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
    6332                 :            :                 gfc_build_addr_expr (pint_type, argc),
    6333                 :            :                 gfc_build_addr_expr (pppchar_type, argv));
    6334                 :        234 :       gfc_add_expr_to_block (&body, tmp);
    6335                 :            :     }
    6336                 :            : 
    6337                 :            :   /* Call _gfortran_set_args (argc, argv).  */
    6338                 :      21186 :   TREE_USED (argc) = 1;
    6339                 :      21186 :   TREE_USED (argv) = 1;
    6340                 :      21186 :   tmp = build_call_expr_loc (input_location,
    6341                 :            :                          gfor_fndecl_set_args, 2, argc, argv);
    6342                 :      21186 :   gfc_add_expr_to_block (&body, tmp);
    6343                 :            : 
    6344                 :            :   /* Add a call to set_options to set up the runtime library Fortran
    6345                 :            :      language standard parameters.  */
    6346                 :      21186 :   {
    6347                 :      21186 :     tree array_type, array, var;
    6348                 :      21186 :     vec<constructor_elt, va_gc> *v = NULL;
    6349                 :      21186 :     static const int noptions = 7;
    6350                 :            : 
    6351                 :            :     /* Passing a new option to the library requires three modifications:
    6352                 :            :           + add it to the tree_cons list below
    6353                 :            :           + change the noptions variable above
    6354                 :            :           + modify the library (runtime/compile_options.c)!  */
    6355                 :            : 
    6356                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6357                 :            :                             build_int_cst (integer_type_node,
    6358                 :            :                                            gfc_option.warn_std));
    6359                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6360                 :            :                             build_int_cst (integer_type_node,
    6361                 :            :                                            gfc_option.allow_std));
    6362                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6363                 :            :                             build_int_cst (integer_type_node, pedantic));
    6364                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6365                 :            :                             build_int_cst (integer_type_node, flag_backtrace));
    6366                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6367                 :            :                             build_int_cst (integer_type_node, flag_sign_zero));
    6368                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6369                 :            :                             build_int_cst (integer_type_node,
    6370                 :            :                                            (gfc_option.rtcheck
    6371                 :            :                                             & GFC_RTCHECK_BOUNDS)));
    6372                 :      21186 :     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
    6373                 :            :                             build_int_cst (integer_type_node,
    6374                 :            :                                            gfc_option.fpe_summary));
    6375                 :            : 
    6376                 :      21186 :     array_type = build_array_type_nelts (integer_type_node, noptions);
    6377                 :      21186 :     array = build_constructor (array_type, v);
    6378                 :      21186 :     TREE_CONSTANT (array) = 1;
    6379                 :      21186 :     TREE_STATIC (array) = 1;
    6380                 :            : 
    6381                 :            :     /* Create a static variable to hold the jump table.  */
    6382                 :      21186 :     var = build_decl (input_location, VAR_DECL,
    6383                 :            :                       create_tmp_var_name ("options"), array_type);
    6384                 :      21186 :     DECL_ARTIFICIAL (var) = 1;
    6385                 :      21186 :     DECL_IGNORED_P (var) = 1;
    6386                 :      21186 :     TREE_CONSTANT (var) = 1;
    6387                 :      21186 :     TREE_STATIC (var) = 1;
    6388                 :      21186 :     TREE_READONLY (var) = 1;
    6389                 :      21186 :     DECL_INITIAL (var) = array;
    6390                 :      21186 :     pushdecl (var);
    6391                 :      21186 :     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
    6392                 :            : 
    6393                 :      21186 :     tmp = build_call_expr_loc (input_location,
    6394                 :            :                            gfor_fndecl_set_options, 2,
    6395                 :            :                            build_int_cst (integer_type_node, noptions), var);
    6396                 :      21186 :     gfc_add_expr_to_block (&body, tmp);
    6397                 :            :   }
    6398                 :            : 
    6399                 :            :   /* If -ffpe-trap option was provided, add a call to set_fpe so that
    6400                 :            :      the library will raise a FPE when needed.  */
    6401                 :      21186 :   if (gfc_option.fpe != 0)
    6402                 :            :     {
    6403                 :          6 :       tmp = build_call_expr_loc (input_location,
    6404                 :            :                              gfor_fndecl_set_fpe, 1,
    6405                 :            :                              build_int_cst (integer_type_node,
    6406                 :            :                                             gfc_option.fpe));
    6407                 :          6 :       gfc_add_expr_to_block (&body, tmp);
    6408                 :            :     }
    6409                 :            : 
    6410                 :            :   /* If this is the main program and an -fconvert option was provided,
    6411                 :            :      add a call to set_convert.  */
    6412                 :            : 
    6413                 :      21186 :   if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
    6414                 :            :     {
    6415                 :         12 :       tmp = build_call_expr_loc (input_location,
    6416                 :            :                              gfor_fndecl_set_convert, 1,
    6417                 :            :                              build_int_cst (integer_type_node, flag_convert));
    6418                 :         12 :       gfc_add_expr_to_block (&body, tmp);
    6419                 :            :     }
    6420                 :            : 
    6421                 :            :   /* If this is the main program and an -frecord-marker option was provided,
    6422                 :            :      add a call to set_record_marker.  */
    6423                 :            : 
    6424                 :      21186 :   if (flag_record_marker != 0)
    6425                 :            :     {
    6426                 :         18 :       tmp = build_call_expr_loc (input_location,
    6427                 :            :                              gfor_fndecl_set_record_marker, 1,
    6428                 :            :                              build_int_cst (integer_type_node,
    6429                 :            :                                             flag_record_marker));
    6430                 :         18 :       gfc_add_expr_to_block (&body, tmp);
    6431                 :            :     }
    6432                 :            : 
    6433                 :      21186 :   if (flag_max_subrecord_length != 0)
    6434                 :            :     {
    6435                 :          6 :       tmp = build_call_expr_loc (input_location,
    6436                 :            :                              gfor_fndecl_set_max_subrecord_length, 1,
    6437                 :            :                              build_int_cst (integer_type_node,
    6438                 :            :                                             flag_max_subrecord_length));
    6439                 :          6 :       gfc_add_expr_to_block (&body, tmp);
    6440                 :            :     }
    6441                 :            : 
    6442                 :            :   /* Call MAIN__().  */
    6443                 :      21186 :   tmp = build_call_expr_loc (input_location,
    6444                 :            :                          fndecl, 0);
    6445                 :      21186 :   gfc_add_expr_to_block (&body, tmp);
    6446                 :            : 
    6447                 :            :   /* Mark MAIN__ as used.  */
    6448                 :      21186 :   TREE_USED (fndecl) = 1;
    6449                 :            : 
    6450                 :            :   /* Coarray: Call _gfortran_caf_finalize(void).  */
    6451                 :      21186 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    6452                 :            :     {
    6453                 :        234 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
    6454                 :        234 :       gfc_add_expr_to_block (&body, tmp);
    6455                 :            :     }
    6456                 :            : 
    6457                 :            :   /* "return 0".  */
    6458                 :      21186 :   tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
    6459                 :      21186 :                          DECL_RESULT (ftn_main),
    6460                 :      21186 :                          build_int_cst (integer_type_node, 0));
    6461                 :      21186 :   tmp = build1_v (RETURN_EXPR, tmp);
    6462                 :      21186 :   gfc_add_expr_to_block (&body, tmp);
    6463                 :            : 
    6464                 :            : 
    6465                 :      21186 :   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
    6466                 :      21186 :   decl = getdecls ();
    6467                 :            : 
    6468                 :            :   /* Finish off this function and send it for code generation.  */
    6469                 :      21186 :   poplevel (1, 1);
    6470                 :      21186 :   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
    6471                 :            : 
    6472                 :      42372 :   DECL_SAVED_TREE (ftn_main)
    6473                 :      21186 :     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
    6474                 :            :                 DECL_INITIAL (ftn_main));
    6475                 :            : 
    6476                 :            :   /* Output the GENERIC tree.  */
    6477                 :      21186 :   dump_function (TDI_original, ftn_main);
    6478                 :            : 
    6479                 :      21186 :   cgraph_node::finalize_function (ftn_main, true);
    6480                 :            : 
    6481                 :      21186 :   if (old_context)
    6482                 :            :     {
    6483                 :          0 :       pop_function_context ();
    6484                 :          0 :       saved_function_decls = saved_parent_function_decls;
    6485                 :            :     }
    6486                 :      21186 :   current_function_decl = old_context;
    6487                 :      21186 : }
    6488                 :            : 
    6489                 :            : 
    6490                 :            : /* Generate an appropriate return-statement for a procedure.  */
    6491                 :            : 
    6492                 :            : tree
    6493                 :      10034 : gfc_generate_return (void)
    6494                 :            : {
    6495                 :      10034 :   gfc_symbol* sym;
    6496                 :      10034 :   tree result;
    6497                 :      10034 :   tree fndecl;
    6498                 :            : 
    6499                 :      10034 :   sym = current_procedure_symbol;
    6500                 :      10034 :   fndecl = sym->backend_decl;
    6501                 :            : 
    6502                 :      10034 :   if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
    6503                 :            :     result = NULL_TREE;
    6504                 :            :   else
    6505                 :            :     {
    6506                 :       8943 :       result = get_proc_result (sym);
    6507                 :            : 
    6508                 :            :       /* Set the return value to the dummy result variable.  The
    6509                 :            :          types may be different for scalar default REAL functions
    6510                 :            :          with -ff2c, therefore we have to convert.  */
    6511                 :       8943 :       if (result != NULL_TREE)
    6512                 :            :         {
    6513                 :       8929 :           result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
    6514                 :       8929 :           result = fold_build2_loc (input_location, MODIFY_EXPR,
    6515                 :       8929 :                                     TREE_TYPE (result), DECL_RESULT (fndecl),
    6516                 :            :                                     result);
    6517                 :            :         }
    6518                 :            :       else
    6519                 :            :         {
    6520                 :            :           /* If the function does not have a result variable, result is
    6521                 :            :              NULL_TREE, and a 'return' is generated without a variable.
    6522                 :            :              The following generates a 'return __result_XXX' where XXX is
    6523                 :            :              the function name.  */
    6524                 :         14 :           if (sym == sym->result && sym->attr.function)
    6525                 :            :             {
    6526                 :          7 :               result = gfc_get_fake_result_decl (sym, 0);
    6527                 :          7 :               result = fold_build2_loc (input_location, MODIFY_EXPR,
    6528                 :          7 :                                         TREE_TYPE (result),
    6529                 :          7 :                                         DECL_RESULT (fndecl), result);
    6530                 :            :             }
    6531                 :            :         }
    6532                 :            :     }
    6533                 :            : 
    6534                 :      10034 :   return build1_v (RETURN_EXPR, result);
    6535                 :            : }
    6536                 :            : 
    6537                 :            : 
    6538                 :            : static void
    6539                 :     542294 : is_from_ieee_module (gfc_symbol *sym)
    6540                 :            : {
    6541                 :     542294 :   if (sym->from_intmod == INTMOD_IEEE_FEATURES
    6542                 :            :       || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
    6543                 :     542294 :       || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
    6544                 :      36891 :     seen_ieee_symbol = 1;
    6545                 :     542294 : }
    6546                 :            : 
    6547                 :            : 
    6548                 :            : static int
    6549                 :      57810 : is_ieee_module_used (gfc_namespace *ns)
    6550                 :            : {
    6551                 :      57810 :   seen_ieee_symbol = 0;
    6552                 :          0 :   gfc_traverse_ns (ns, is_from_ieee_module);
    6553                 :      57810 :   return seen_ieee_symbol;
    6554                 :            : }
    6555                 :            : 
    6556                 :            : 
    6557                 :            : static gfc_omp_clauses *module_oacc_clauses;
    6558                 :            : 
    6559                 :            : 
    6560                 :            : static void
    6561                 :         42 : add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
    6562                 :            : {
    6563                 :         42 :   gfc_omp_namelist *n;
    6564                 :            : 
    6565                 :         42 :   n = gfc_get_omp_namelist ();
    6566                 :         42 :   n->sym = sym;
    6567                 :         42 :   n->u.map_op = map_op;
    6568                 :            : 
    6569                 :         42 :   if (!module_oacc_clauses)
    6570                 :         20 :     module_oacc_clauses = gfc_get_omp_clauses ();
    6571                 :            : 
    6572                 :         42 :   if (module_oacc_clauses->lists[OMP_LIST_MAP])
    6573                 :         22 :     n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
    6574                 :            : 
    6575                 :         42 :   module_oacc_clauses->lists[OMP_LIST_MAP] = n;
    6576                 :         42 : }
    6577                 :            : 
    6578                 :            : 
    6579                 :            : static void
    6580                 :     558830 : find_module_oacc_declare_clauses (gfc_symbol *sym)
    6581                 :            : {
    6582                 :     558830 :   if (sym->attr.use_assoc)
    6583                 :            :     {
    6584                 :     180504 :       gfc_omp_map_op map_op;
    6585                 :            : 
    6586                 :     180504 :       if (sym->attr.oacc_declare_create)
    6587                 :            :         map_op = OMP_MAP_FORCE_ALLOC;
    6588                 :            : 
    6589                 :     180504 :       if (sym->attr.oacc_declare_copyin)
    6590                 :            :         map_op = OMP_MAP_FORCE_TO;
    6591                 :            : 
    6592                 :     180504 :       if (sym->attr.oacc_declare_deviceptr)
    6593                 :          0 :         map_op = OMP_MAP_FORCE_DEVICEPTR;
    6594                 :            : 
    6595                 :     180504 :       if (sym->attr.oacc_declare_device_resident)
    6596                 :         26 :         map_op = OMP_MAP_DEVICE_RESIDENT;
    6597                 :            : 
    6598                 :     180504 :       if (sym->attr.oacc_declare_create
    6599                 :            :           || sym->attr.oacc_declare_copyin
    6600                 :            :           || sym->attr.oacc_declare_deviceptr
    6601                 :     180504 :           || sym->attr.oacc_declare_device_resident)
    6602                 :            :         {
    6603                 :         42 :           sym->attr.referenced = 1;
    6604                 :         42 :           add_clause (sym, map_op);
    6605                 :            :         }
    6606                 :            :     }
    6607                 :     558830 : }
    6608                 :            : 
    6609                 :            : 
    6610                 :            : void
    6611                 :      64772 : finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
    6612                 :            : {
    6613                 :      64772 :   gfc_code *code;
    6614                 :      64772 :   gfc_oacc_declare *oc;
    6615                 :      64772 :   locus where = gfc_current_locus;
    6616                 :      64772 :   gfc_omp_clauses *omp_clauses = NULL;
    6617                 :      64772 :   gfc_omp_namelist *n, *p;
    6618                 :            : 
    6619                 :      64772 :   module_oacc_clauses = NULL;
    6620                 :      64772 :   gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
    6621                 :            : 
    6622                 :      64772 :   if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
    6623                 :            :     {
    6624                 :         19 :       gfc_oacc_declare *new_oc;
    6625                 :            : 
    6626                 :         19 :       new_oc = gfc_get_oacc_declare ();
    6627                 :         19 :       new_oc->next = ns->oacc_declare;
    6628                 :         19 :       new_oc->clauses = module_oacc_clauses;
    6629                 :            : 
    6630                 :         19 :       ns->oacc_declare = new_oc;
    6631                 :            :     }
    6632                 :            : 
    6633                 :      64772 :   if (!ns->oacc_declare)
    6634                 :            :     return;
    6635                 :            : 
    6636                 :        122 :   for (oc = ns->oacc_declare; oc; oc = oc->next)
    6637                 :            :     {
    6638                 :         67 :       if (oc->module_var)
    6639                 :          0 :         continue;
    6640                 :            : 
    6641                 :         67 :       if (block)
    6642                 :          2 :         gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
    6643                 :            :                    "in BLOCK construct", &oc->loc);
    6644                 :            : 
    6645                 :            : 
    6646                 :         67 :       if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
    6647                 :            :         {
    6648                 :         55 :           if (omp_clauses == NULL)
    6649                 :            :             {
    6650                 :         43 :               omp_clauses = oc->clauses;
    6651                 :         43 :               continue;
    6652                 :            :             }
    6653                 :            : 
    6654                 :         48 :           for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
    6655                 :            :             ;
    6656                 :            : 
    6657                 :         12 :           gcc_assert (p->next == NULL);
    6658                 :            : 
    6659                 :         12 :           p->next = omp_clauses->lists[OMP_LIST_MAP];
    6660                 :         12 :           omp_clauses = oc->clauses;
    6661                 :            :         }
    6662                 :            :     }
    6663                 :            : 
    6664                 :         55 :   if (!omp_clauses)
    6665                 :            :     return;
    6666                 :            : 
    6667                 :        142 :   for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
    6668                 :            :     {
    6669                 :         99 :       switch (n->u.map_op)
    6670                 :            :         {
    6671                 :         25 :           case OMP_MAP_DEVICE_RESIDENT:
    6672                 :         25 :             n->u.map_op = OMP_MAP_FORCE_ALLOC;
    6673                 :         25 :             break;
    6674                 :            : 
    6675                 :            :           default:
    6676                 :            :             break;
    6677                 :            :         }
    6678                 :            :     }
    6679                 :            : 
    6680                 :         43 :   code = XCNEW (gfc_code);
    6681                 :         43 :   code->op = EXEC_OACC_DECLARE;
    6682                 :         43 :   code->loc = where;
    6683                 :            : 
    6684                 :         43 :   code->ext.oacc_declare = gfc_get_oacc_declare ();
    6685                 :         43 :   code->ext.oacc_declare->clauses = omp_clauses;
    6686                 :            : 
    6687                 :         43 :   code->block = XCNEW (gfc_code);
    6688                 :         43 :   code->block->op = EXEC_OACC_DECLARE;
    6689                 :         43 :   code->block->loc = where;
    6690                 :            : 
    6691                 :         43 :   if (ns->code)
    6692                 :         40 :     code->block->next = ns->code;
    6693                 :            : 
    6694                 :         43 :   ns->code = code;
    6695                 :            : 
    6696                 :         43 :   return;
    6697                 :            : }
    6698                 :            : 
    6699                 :            : 
    6700                 :            : /* Generate code for a function.  */
    6701                 :            : 
    6702                 :            : void
    6703                 :      57810 : gfc_generate_function_code (gfc_namespace * ns)
    6704                 :            : {
    6705                 :      57810 :   tree fndecl;
    6706                 :      57810 :   tree old_context;
    6707                 :      57810 :   tree decl;
    6708                 :      57810 :   tree tmp;
    6709                 :      57810 :   tree fpstate = NULL_TREE;
    6710                 :      57810 :   stmtblock_t init, cleanup;
    6711                 :      57810 :   stmtblock_t body;
    6712                 :      57810 :   gfc_wrapped_block try_block;
    6713                 :      57810 :   tree recurcheckvar = NULL_TREE;
    6714                 :      57810 :   gfc_symbol *sym;
    6715                 :      57810 :   gfc_symbol *previous_procedure_symbol;
    6716                 :      57810 :   int rank, ieee;
    6717                 :      57810 :   bool is_recursive;
    6718                 :            : 
    6719                 :      57810 :   sym = ns->proc_name;
    6720                 :      57810 :   previous_procedure_symbol = current_procedure_symbol;
    6721                 :      57810 :   current_procedure_symbol = sym;
    6722                 :            : 
    6723                 :            :   /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
    6724                 :            :      lost or worse.  */
    6725                 :      57810 :   sym->tlink = sym;
    6726                 :            : 
    6727                 :            :   /* Create the declaration for functions with global scope.  */
    6728                 :      57810 :   if (!sym->backend_decl)
    6729                 :      28967 :     gfc_create_function_decl (ns, false);
    6730                 :            : 
    6731                 :      57810 :   fndecl = sym->backend_decl;
    6732                 :      57810 :   old_context = current_function_decl;
    6733                 :            : 
    6734                 :      57810 :   if (old_context)
    6735                 :            :     {
    6736                 :      12213 :       push_function_context ();
    6737                 :      12213 :       saved_parent_function_decls = saved_function_decls;
    6738                 :      12213 :       saved_function_decls = NULL_TREE;
    6739                 :            :     }
    6740                 :            : 
    6741                 :      57810 :   trans_function_start (sym);
    6742                 :            : 
    6743                 :      57810 :   gfc_init_block (&init);
    6744                 :            : 
    6745                 :      57810 :   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
    6746                 :            :     {
    6747                 :            :       /* Copy length backend_decls to all entry point result
    6748                 :            :          symbols.  */
    6749                 :         49 :       gfc_entry_list *el;
    6750                 :         49 :       tree backend_decl;
    6751                 :            : 
    6752                 :         49 :       gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
    6753                 :         49 :       backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
    6754                 :        183 :       for (el = ns->entries; el; el = el->next)
    6755                 :        134 :         el->sym->result->ts.u.cl->backend_decl = backend_decl;
    6756                 :            :     }
    6757                 :            : 
    6758                 :            :   /* Translate COMMON blocks.  */
    6759                 :      57810 :   gfc_trans_common (ns);
    6760                 :            : 
    6761                 :            :   /* Null the parent fake result declaration if this namespace is
    6762                 :            :      a module function or an external procedures.  */
    6763                 :      57810 :   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
    6764                 :      41889 :         || ns->parent == NULL)
    6765                 :      45597 :     parent_fake_result_decl = NULL_TREE;
    6766                 :            : 
    6767                 :      57810 :   gfc_generate_contained_functions (ns);
    6768                 :            : 
    6769                 :      57810 :   has_coarray_vars = false;
    6770                 :      57810 :   generate_local_vars (ns);
    6771                 :            : 
    6772                 :      57810 :   if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
    6773                 :        138 :     generate_coarray_init (ns);
    6774                 :            : 
    6775                 :            :   /* Keep the parent fake result declaration in module functions
    6776                 :            :      or external procedures.  */
    6777                 :      57810 :   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
    6778                 :      41889 :         || ns->parent == NULL)
    6779                 :      45597 :     current_fake_result_decl = parent_fake_result_decl;
    6780                 :            :   else
    6781                 :      12213 :     current_fake_result_decl = NULL_TREE;
    6782                 :            : 
    6783                 :     115620 :   is_recursive = sym->attr.recursive
    6784                 :     114078 :                  || (sym->attr.entry_master
    6785                 :      57810 :                      && sym->ns->entries->sym->attr.recursive);
    6786                 :      57810 :   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
    6787                 :        508 :       && !is_recursive && !flag_recursive)
    6788                 :            :     {
    6789                 :        463 :       char * msg;
    6790                 :            : 
    6791                 :        463 :       msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
    6792                 :            :                        sym->name);
    6793                 :        463 :       recurcheckvar = gfc_create_var (logical_type_node, "is_recursive");
    6794                 :        463 :       TREE_STATIC (recurcheckvar) = 1;
    6795                 :        463 :       DECL_INITIAL (recurcheckvar) = logical_false_node;
    6796                 :        463 :       gfc_add_expr_to_block (&init, recurcheckvar);
    6797                 :        463 :       gfc_trans_runtime_check (true, false, recurcheckvar, &init,
    6798                 :            :                                &sym->declared_at, msg);
    6799                 :        463 :       gfc_add_modify (&init, recurcheckvar, logical_true_node);
    6800                 :        463 :       free (msg);
    6801                 :            :     }
    6802                 :            : 
    6803                 :            :   /* Check if an IEEE module is used in the procedure.  If so, save
    6804                 :            :      the floating point state.  */
    6805                 :      57810 :   ieee = is_ieee_module_used (ns);
    6806                 :      57810 :   if (ieee)
    6807                 :        181 :     fpstate = gfc_save_fp_state (&init);
    6808                 :            : 
    6809                 :            :   /* Now generate the code for the body of this function.  */
    6810                 :      57810 :   gfc_init_block (&body);
    6811                 :            : 
    6812                 :      57810 :   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
    6813                 :      57810 :         && sym->attr.subroutine)
    6814                 :            :     {
    6815                 :         42 :       tree alternate_return;
    6816                 :         42 :       alternate_return = gfc_get_fake_result_decl (sym, 0);
    6817                 :         42 :       gfc_add_modify (&body, alternate_return, integer_zero_node);
    6818                 :            :     }
    6819                 :            : 
    6820                 :      57810 :   if (ns->entries)
    6821                 :            :     {
    6822                 :            :       /* Jump to the correct entry point.  */
    6823                 :        574 :       tmp = gfc_trans_entry_master_switch (ns->entries);
    6824                 :        574 :       gfc_add_expr_to_block (&body, tmp);
    6825                 :            :     }
    6826                 :            : 
    6827                 :            :   /* If bounds-checking is enabled, generate code to check passed in actual
    6828                 :            :      arguments against the expected dummy argument attributes (e.g. string
    6829                 :            :      lengths).  */
    6830                 :      57810 :   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
    6831                 :       2076 :     add_argument_checking (&body, sym);
    6832                 :            : 
    6833                 :      57810 :   finish_oacc_declare (ns, sym, false);
    6834                 :            : 
    6835                 :      57810 :   tmp = gfc_trans_code (ns->code);
    6836                 :      57810 :   gfc_add_expr_to_block (&body, tmp);
    6837                 :            : 
    6838                 :      57810 :   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
    6839                 :      57810 :       || (sym->result && sym->result != sym
    6840                 :        853 :           && sym->result->ts.type == BT_DERIVED
    6841                 :         39 :           && sym->result->ts.u.derived->attr.alloc_comp))
    6842                 :            :     {
    6843                 :       8487 :       bool artificial_result_decl = false;
    6844                 :       8487 :       tree result = get_proc_result (sym);
    6845                 :       8487 :       gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
    6846                 :            : 
    6847                 :            :       /* Make sure that a function returning an object with
    6848                 :            :          alloc/pointer_components always has a result, where at least
    6849                 :            :          the allocatable/pointer components are set to zero.  */
    6850                 :       8487 :       if (result == NULL_TREE && sym->attr.function
    6851                 :        220 :           && ((sym->result->ts.type == BT_DERIVED
    6852                 :         70 :                && (sym->attr.allocatable
    6853                 :         70 :                    || sym->attr.pointer
    6854                 :         62 :                    || sym->result->ts.u.derived->attr.alloc_comp
    6855                 :         62 :                    || sym->result->ts.u.derived->attr.pointer_comp))
    6856                 :        194 :               || (sym->result->ts.type == BT_CLASS
    6857                 :         29 :                   && (CLASS_DATA (sym)->attr.allocatable
    6858                 :         29 :                       || CLASS_DATA (sym)->attr.class_pointer
    6859                 :          0 :                       || CLASS_DATA (sym->result)->attr.alloc_comp
    6860                 :          0 :                       || CLASS_DATA (sym->result)->attr.pointer_comp))))
    6861                 :            :         {
    6862                 :         55 :           artificial_result_decl = true;
    6863                 :         55 :           result = gfc_get_fake_result_decl (sym, 0);
    6864                 :            :         }
    6865                 :            : 
    6866                 :       8487 :       if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
    6867                 :            :         {
    6868                 :       7955 :           if (sym->attr.allocatable && sym->attr.dimension == 0
    6869                 :         44 :               && sym->result == sym)
    6870                 :         25 :             gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
    6871                 :            :                                                          null_pointer_node));
    6872                 :       7930 :           else if (sym->ts.type == BT_CLASS
    6873                 :        478 :                    && CLASS_DATA (sym)->attr.allocatable
    6874                 :        478 :                    && CLASS_DATA (sym)->attr.dimension == 0
    6875                 :        228 :                    && sym->result == sym)
    6876                 :            :             {
    6877                 :        110 :               tmp = CLASS_DATA (sym)->backend_decl;
    6878                 :        110 :               tmp = fold_build3_loc (input_location, COMPONENT_REF,
    6879                 :        110 :                                      TREE_TYPE (tmp), result, tmp, NULL_TREE);
    6880                 :        110 :               gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
    6881                 :            :                                                         null_pointer_node));
    6882                 :            :             }
    6883                 :       7820 :           else if (sym->ts.type == BT_DERIVED
    6884                 :        507 :                    && !sym->attr.allocatable)
    6885                 :            :             {
    6886                 :        495 :               gfc_expr *init_exp;
    6887                 :            :               /* Arrays are not initialized using the default initializer of
    6888                 :            :                  their elements.  Therefore only check if a default
    6889                 :            :                  initializer is available when the result is scalar.  */
    6890                 :        495 :               init_exp = rsym->as ? NULL
    6891                 :        488 :                                   : gfc_generate_initializer (&rsym->ts, true);
    6892                 :        488 :               if (init_exp)
    6893                 :            :                 {
    6894                 :        286 :                   tmp = gfc_trans_structure_assign (result, init_exp, 0);
    6895                 :        286 :                   gfc_free_expr (init_exp);
    6896                 :        286 :                   gfc_add_expr_to_block (&init, tmp);
    6897                 :            :                 }
    6898                 :        209 :               else if (rsym->ts.u.derived->attr.alloc_comp)
    6899                 :            :                 {
    6900                 :          7 :                   rank = rsym->as ? rsym->as->rank : 0;
    6901                 :          7 :                   tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
    6902                 :            :                                                 rank);
    6903                 :          7 :                   gfc_prepend_expr_to_block (&body, tmp);
    6904                 :            :                 }
    6905                 :            :             }
    6906                 :            :         }
    6907                 :            : 
    6908                 :       8487 :       if (result == NULL_TREE || artificial_result_decl)
    6909                 :            :         {
    6910                 :            :           /* TODO: move to the appropriate place in resolve.c.  */
    6911                 :        220 :           if (warn_return_type > 0 && sym == sym->result)
    6912                 :         40 :             gfc_warning (OPT_Wreturn_type,
    6913                 :            :                          "Return value of function %qs at %L not set",
    6914                 :            :                          sym->name, &sym->declared_at);
    6915                 :        220 :           if (warn_return_type > 0)
    6916                 :         45 :             TREE_NO_WARNING(sym->backend_decl) = 1;
    6917                 :            :         }
    6918                 :       8487 :       if (result != NULL_TREE)
    6919                 :       8322 :         gfc_add_expr_to_block (&body, gfc_generate_return ());
    6920                 :            :     }
    6921                 :            : 
    6922                 :      57810 :   gfc_init_block (&cleanup);
    6923                 :            : 
    6924                 :            :   /* Reset recursion-check variable.  */
    6925                 :      57810 :   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
    6926                 :        508 :       && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
    6927                 :            :     {
    6928                 :        463 :       gfc_add_modify (&cleanup, recurcheckvar, logical_false_node);
    6929                 :        463 :       recurcheckvar = NULL;
    6930                 :            :     }
    6931                 :            : 
    6932                 :            :   /* If IEEE modules are loaded, restore the floating-point state.  */
    6933                 :      57810 :   if (ieee)
    6934                 :        181 :     gfc_restore_fp_state (&cleanup, fpstate);
    6935                 :            : 
    6936                 :            :   /* Finish the function body and add init and cleanup code.  */
    6937                 :      57810 :   tmp = gfc_finish_block (&body);
    6938                 :      57810 :   gfc_start_wrapped_block (&try_block, tmp);
    6939                 :            :   /* Add code to create and cleanup arrays.  */
    6940                 :      57810 :   gfc_trans_deferred_vars (sym, &try_block);
    6941                 :      57810 :   gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
    6942                 :            :                         gfc_finish_block (&cleanup));
    6943                 :            : 
    6944                 :            :   /* Add all the decls we created during processing.  */
    6945                 :      57810 :   decl = nreverse (saved_function_decls);
    6946                 :     260627 :   while (decl)
    6947                 :            :     {
    6948                 :     202817 :       tree next;
    6949                 :            : 
    6950                 :     202817 :       next = DECL_CHAIN (decl);
    6951                 :     202817 :       DECL_CHAIN (decl) = NULL_TREE;
    6952                 :     202817 :       pushdecl (decl);
    6953                 :     202817 :       decl = next;
    6954                 :            :     }
    6955                 :      57810 :   saved_function_decls = NULL_TREE;
    6956                 :            : 
    6957                 :      57810 :   DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
    6958                 :      57810 :   decl = getdecls ();
    6959                 :            : 
    6960                 :            :   /* Finish off this function and send it for code generation.  */
    6961                 :      57810 :   poplevel (1, 1);
    6962                 :      57810 :   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
    6963                 :            : 
    6964                 :     115620 :   DECL_SAVED_TREE (fndecl)
    6965                 :      57810 :     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
    6966                 :            :                 DECL_INITIAL (fndecl));
    6967                 :            : 
    6968                 :            :   /* Output the GENERIC tree.  */
    6969                 :      57810 :   dump_function (TDI_original, fndecl);
    6970                 :            : 
    6971                 :            :   /* Store the end of the function, so that we get good line number
    6972                 :            :      info for the epilogue.  */
    6973                 :      57810 :   cfun->function_end_locus = input_location;
    6974                 :            : 
    6975                 :            :   /* We're leaving the context of this function, so zap cfun.
    6976                 :            :      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
    6977                 :            :      tree_rest_of_compilation.  */
    6978                 :      57810 :   set_cfun (NULL);
    6979                 :            : 
    6980                 :      57810 :   if (old_context)
    6981                 :            :     {
    6982                 :      12213 :       pop_function_context ();
    6983                 :      12213 :       saved_function_decls = saved_parent_function_decls;
    6984                 :            :     }
    6985                 :      57810 :   current_function_decl = old_context;
    6986                 :            : 
    6987                 :      57810 :   if (decl_function_context (fndecl))
    6988                 :            :     {
    6989                 :            :       /* Register this function with cgraph just far enough to get it
    6990                 :            :          added to our parent's nested function list.
    6991                 :            :          If there are static coarrays in this function, the nested _caf_init
    6992                 :            :          function has already called cgraph_create_node, which also created
    6993                 :            :          the cgraph node for this function.  */
    6994                 :      12213 :       if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
    6995                 :      12203 :         (void) cgraph_node::get_create (fndecl);
    6996                 :            :     }
    6997                 :            :   else
    6998                 :      45597 :     cgraph_node::finalize_function (fndecl, true);
    6999                 :            : 
    7000                 :      57810 :   gfc_trans_use_stmts (ns);
    7001                 :      57810 :   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
    7002                 :            : 
    7003                 :      57810 :   if (sym->attr.is_main_program)
    7004                 :      21186 :     create_main_function (fndecl);
    7005                 :            : 
    7006                 :      57810 :   current_procedure_symbol = previous_procedure_symbol;
    7007                 :      57810 : }
    7008                 :            : 
    7009                 :            : 
    7010                 :            : void
    7011                 :      25167 : gfc_generate_constructors (void)
    7012                 :            : {
    7013                 :      25167 :   gcc_assert (gfc_static_ctors == NULL_TREE);
    7014                 :            : #if 0
    7015                 :            :   tree fnname;
    7016                 :            :   tree type;
    7017                 :            :   tree fndecl;
    7018                 :            :   tree decl;
    7019                 :            :   tree tmp;
    7020                 :            : 
    7021                 :            :   if (gfc_static_ctors == NULL_TREE)
    7022                 :            :     return;
    7023                 :            : 
    7024                 :            :   fnname = get_file_function_name ("I");
    7025                 :            :   type = build_function_type_list (void_type_node, NULL_TREE);
    7026                 :            : 
    7027                 :            :   fndecl = build_decl (input_location,
    7028                 :            :                        FUNCTION_DECL, fnname, type);
    7029                 :            :   TREE_PUBLIC (fndecl) = 1;
    7030                 :            : 
    7031                 :            :   decl = build_decl (input_location,
    7032                 :            :                      RESULT_DECL, NULL_TREE, void_type_node);
    7033                 :            :   DECL_ARTIFICIAL (decl) = 1;
    7034                 :            :   DECL_IGNORED_P (decl) = 1;
    7035                 :            :   DECL_CONTEXT (decl) = fndecl;
    7036                 :            :   DECL_RESULT (fndecl) = decl;
    7037                 :            : 
    7038                 :            :   pushdecl (fndecl);
    7039                 :            : 
    7040                 :            :   current_function_decl = fndecl;
    7041                 :            : 
    7042                 :            :   rest_of_decl_compilation (fndecl, 1, 0);
    7043                 :            : 
    7044                 :            :   make_decl_rtl (fndecl);
    7045                 :            : 
    7046                 :            :   allocate_struct_function (fndecl, false);
    7047                 :            : 
    7048                 :            :   pushlevel ();
    7049                 :            : 
    7050                 :            :   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
    7051                 :            :     {
    7052                 :            :       tmp = build_call_expr_loc (input_location,
    7053                 :            :                              TREE_VALUE (gfc_static_ctors), 0);
    7054                 :            :       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
    7055                 :            :     }
    7056                 :            : 
    7057                 :            :   decl = getdecls ();
    7058                 :            :   poplevel (1, 1);
    7059                 :            : 
    7060                 :            :   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
    7061                 :            :   DECL_SAVED_TREE (fndecl)
    7062                 :            :     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
    7063                 :            :                 DECL_INITIAL (fndecl));
    7064                 :            : 
    7065                 :            :   free_after_parsing (cfun);
    7066                 :            :   free_after_compilation (cfun);
    7067                 :            : 
    7068                 :            :   tree_rest_of_compilation (fndecl);
    7069                 :            : 
    7070                 :            :   current_function_decl = NULL_TREE;
    7071                 :            : #endif
    7072                 :      25167 : }
    7073                 :            : 
    7074                 :            : /* Translates a BLOCK DATA program unit. This means emitting the
    7075                 :            :    commons contained therein plus their initializations. We also emit
    7076                 :            :    a globally visible symbol to make sure that each BLOCK DATA program
    7077                 :            :    unit remains unique.  */
    7078                 :            : 
    7079                 :            : void
    7080                 :         65 : gfc_generate_block_data (gfc_namespace * ns)
    7081                 :            : {
    7082                 :         65 :   tree decl;
    7083                 :         65 :   tree id;
    7084                 :            : 
    7085                 :            :   /* Tell the backend the source location of the block data.  */
    7086                 :         65 :   if (ns->proc_name)
    7087                 :         28 :     gfc_set_backend_locus (&ns->proc_name->declared_at);
    7088                 :            :   else
    7089                 :         37 :     gfc_set_backend_locus (&gfc_current_locus);
    7090                 :            : 
    7091                 :            :   /* Process the DATA statements.  */
    7092                 :         65 :   gfc_trans_common (ns);
    7093                 :            : 
    7094                 :            :   /* Create a global symbol with the mane of the block data.  This is to
    7095                 :            :      generate linker errors if the same name is used twice.  It is never
    7096                 :            :      really used.  */
    7097                 :         65 :   if (ns->proc_name)
    7098                 :         28 :     id = gfc_sym_mangled_function_id (ns->proc_name);
    7099                 :            :   else
    7100                 :         37 :     id = get_identifier ("__BLOCK_DATA__");
    7101                 :            : 
    7102                 :         65 :   decl = build_decl (input_location,
    7103                 :            :                      VAR_DECL, id, gfc_array_index_type);
    7104                 :         65 :   TREE_PUBLIC (decl) = 1;
    7105                 :         65 :   TREE_STATIC (decl) = 1;
    7106                 :         65 :   DECL_IGNORED_P (decl) = 1;
    7107                 :            : 
    7108                 :         65 :   pushdecl (decl);
    7109                 :         65 :   rest_of_decl_compilation (decl, 1, 0);
    7110                 :         65 : }
    7111                 :            : 
    7112                 :            : 
    7113                 :            : /* Process the local variables of a BLOCK construct.  */
    7114                 :            : 
    7115                 :            : void
    7116                 :       6962 : gfc_process_block_locals (gfc_namespace* ns)
    7117                 :            : {
    7118                 :       6962 :   tree decl;
    7119                 :            : 
    7120                 :       6962 :   saved_local_decls = NULL_TREE;
    7121                 :       6962 :   has_coarray_vars = false;
    7122                 :            : 
    7123                 :       6962 :   generate_local_vars (ns);
    7124                 :            : 
    7125                 :       6962 :   if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
    7126                 :         25 :     generate_coarray_init (ns);
    7127                 :            : 
    7128                 :       6962 :   decl = nreverse (saved_local_decls);
    7129                 :      14653 :   while (decl)
    7130                 :            :     {
    7131                 :       7691 :       tree next;
    7132                 :            : 
    7133                 :       7691 :       next = DECL_CHAIN (decl);
    7134                 :       7691 :       DECL_CHAIN (decl) = NULL_TREE;
    7135                 :       7691 :       pushdecl (decl);
    7136                 :       7691 :       decl = next;
    7137                 :            :     }
    7138                 :       6962 :   saved_local_decls = NULL_TREE;
    7139                 :       6962 : }
    7140                 :            : 
    7141                 :            : 
    7142                 :            : #include "gt-fortran-trans-decl.h"

Generated by: LCOV version 1.0

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