LCOV - code coverage report
Current view: top level - gcc/fortran - trans-types.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 92.7 % 1760 1632
Test Date: 2024-07-13 14:16:58 Functions: 87.3 % 63 55
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Backend support for Fortran 95 basic types and derived types.
       2                 :             :    Copyright (C) 2002-2024 Free Software Foundation, Inc.
       3                 :             :    Contributed by Paul Brook <paul@nowt.org>
       4                 :             :    and Steven Bosscher <s.bosscher@student.tudelft.nl>
       5                 :             : 
       6                 :             : This file is part of GCC.
       7                 :             : 
       8                 :             : GCC is free software; you can redistribute it and/or modify it under
       9                 :             : the terms of the GNU General Public License as published by the Free
      10                 :             : Software Foundation; either version 3, or (at your option) any later
      11                 :             : version.
      12                 :             : 
      13                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      14                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      15                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      16                 :             : for more details.
      17                 :             : 
      18                 :             : You should have received a copy of the GNU General Public License
      19                 :             : along with GCC; see the file COPYING3.  If not see
      20                 :             : <http://www.gnu.org/licenses/>.  */
      21                 :             : 
      22                 :             : /* trans-types.cc -- gfortran backend types */
      23                 :             : 
      24                 :             : #include "config.h"
      25                 :             : #include "system.h"
      26                 :             : #include "coretypes.h"
      27                 :             : #include "target.h"
      28                 :             : #include "tree.h"
      29                 :             : #include "gfortran.h"
      30                 :             : #include "trans.h"
      31                 :             : #include "stringpool.h"
      32                 :             : #include "fold-const.h"
      33                 :             : #include "stor-layout.h"
      34                 :             : #include "langhooks.h"        /* For iso-c-bindings.def.  */
      35                 :             : #include "toplev.h"   /* For rest_of_decl_compilation.  */
      36                 :             : #include "trans-types.h"
      37                 :             : #include "trans-const.h"
      38                 :             : #include "trans-array.h"
      39                 :             : #include "dwarf2out.h"        /* For struct array_descr_info.  */
      40                 :             : #include "attribs.h"
      41                 :             : #include "alias.h"
      42                 :             : 
      43                 :             : 
      44                 :             : #if (GFC_MAX_DIMENSIONS < 10)
      45                 :             : #define GFC_RANK_DIGITS 1
      46                 :             : #define GFC_RANK_PRINTF_FORMAT "%01d"
      47                 :             : #elif (GFC_MAX_DIMENSIONS < 100)
      48                 :             : #define GFC_RANK_DIGITS 2
      49                 :             : #define GFC_RANK_PRINTF_FORMAT "%02d"
      50                 :             : #else
      51                 :             : #error If you really need >99 dimensions, continue the sequence above...
      52                 :             : #endif
      53                 :             : 
      54                 :             : /* array of structs so we don't have to worry about xmalloc or free */
      55                 :             : CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
      56                 :             : 
      57                 :             : tree gfc_array_index_type;
      58                 :             : tree gfc_array_range_type;
      59                 :             : tree gfc_character1_type_node;
      60                 :             : tree pvoid_type_node;
      61                 :             : tree prvoid_type_node;
      62                 :             : tree ppvoid_type_node;
      63                 :             : tree pchar_type_node;
      64                 :             : static tree pfunc_type_node;
      65                 :             : 
      66                 :             : tree logical_type_node;
      67                 :             : tree logical_true_node;
      68                 :             : tree logical_false_node;
      69                 :             : tree gfc_charlen_type_node;
      70                 :             : 
      71                 :             : tree gfc_float128_type_node = NULL_TREE;
      72                 :             : tree gfc_complex_float128_type_node = NULL_TREE;
      73                 :             : 
      74                 :             : bool gfc_real16_is_float128 = false;
      75                 :             : bool gfc_real16_use_iec_60559 = false;
      76                 :             : 
      77                 :             : static GTY(()) tree gfc_desc_dim_type;
      78                 :             : static GTY(()) tree gfc_max_array_element_size;
      79                 :             : static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
      80                 :             : static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
      81                 :             : static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
      82                 :             : 
      83                 :             : /* Arrays for all integral and real kinds.  We'll fill this in at runtime
      84                 :             :    after the target has a chance to process command-line options.  */
      85                 :             : 
      86                 :             : #define MAX_INT_KINDS 5
      87                 :             : gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
      88                 :             : gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
      89                 :             : static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
      90                 :             : static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
      91                 :             : 
      92                 :             : #define MAX_REAL_KINDS 5
      93                 :             : gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
      94                 :             : static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
      95                 :             : static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
      96                 :             : 
      97                 :             : #define MAX_CHARACTER_KINDS 2
      98                 :             : gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
      99                 :             : static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
     100                 :             : static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
     101                 :             : 
     102                 :             : static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);
     103                 :             : 
     104                 :             : /* The integer kind to use for array indices.  This will be set to the
     105                 :             :    proper value based on target information from the backend.  */
     106                 :             : 
     107                 :             : int gfc_index_integer_kind;
     108                 :             : 
     109                 :             : /* The default kinds of the various types.  */
     110                 :             : 
     111                 :             : int gfc_default_integer_kind;
     112                 :             : int gfc_max_integer_kind;
     113                 :             : int gfc_default_real_kind;
     114                 :             : int gfc_default_double_kind;
     115                 :             : int gfc_default_character_kind;
     116                 :             : int gfc_default_logical_kind;
     117                 :             : int gfc_default_complex_kind;
     118                 :             : int gfc_c_int_kind;
     119                 :             : int gfc_c_intptr_kind;
     120                 :             : int gfc_atomic_int_kind;
     121                 :             : int gfc_atomic_logical_kind;
     122                 :             : 
     123                 :             : /* The kind size used for record offsets. If the target system supports
     124                 :             :    kind=8, this will be set to 8, otherwise it is set to 4.  */
     125                 :             : int gfc_intio_kind;
     126                 :             : 
     127                 :             : /* The integer kind used to store character lengths.  */
     128                 :             : int gfc_charlen_int_kind;
     129                 :             : 
     130                 :             : /* Kind of internal integer for storing object sizes.  */
     131                 :             : int gfc_size_kind;
     132                 :             : 
     133                 :             : /* The size of the numeric storage unit and character storage unit.  */
     134                 :             : int gfc_numeric_storage_size;
     135                 :             : int gfc_character_storage_size;
     136                 :             : 
     137                 :             : static tree dtype_type_node = NULL_TREE;
     138                 :             : 
     139                 :             : 
     140                 :             : /* Build the dtype_type_node if necessary.  */
     141                 :      368342 : tree get_dtype_type_node (void)
     142                 :             : {
     143                 :      368342 :   tree field;
     144                 :      368342 :   tree dtype_node;
     145                 :      368342 :   tree *dtype_chain = NULL;
     146                 :             : 
     147                 :      368342 :   if (dtype_type_node == NULL_TREE)
     148                 :             :     {
     149                 :       29859 :       dtype_node = make_node (RECORD_TYPE);
     150                 :       29859 :       TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
     151                 :       29859 :       TYPE_NAMELESS (dtype_node) = 1;
     152                 :       29859 :       field = gfc_add_field_to_struct_1 (dtype_node,
     153                 :             :                                          get_identifier ("elem_len"),
     154                 :             :                                          size_type_node, &dtype_chain);
     155                 :       29859 :       suppress_warning (field);
     156                 :       29859 :       field = gfc_add_field_to_struct_1 (dtype_node,
     157                 :             :                                          get_identifier ("version"),
     158                 :             :                                          integer_type_node, &dtype_chain);
     159                 :       29859 :       suppress_warning (field);
     160                 :       29859 :       field = gfc_add_field_to_struct_1 (dtype_node,
     161                 :             :                                          get_identifier ("rank"),
     162                 :             :                                          signed_char_type_node, &dtype_chain);
     163                 :       29859 :       suppress_warning (field);
     164                 :       29859 :       field = gfc_add_field_to_struct_1 (dtype_node,
     165                 :             :                                          get_identifier ("type"),
     166                 :             :                                          signed_char_type_node, &dtype_chain);
     167                 :       29859 :       suppress_warning (field);
     168                 :       29859 :       field = gfc_add_field_to_struct_1 (dtype_node,
     169                 :             :                                          get_identifier ("attribute"),
     170                 :             :                                          short_integer_type_node, &dtype_chain);
     171                 :       29859 :       suppress_warning (field);
     172                 :       29859 :       gfc_finish_type (dtype_node);
     173                 :       29859 :       TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
     174                 :       29859 :       dtype_type_node = dtype_node;
     175                 :             :     }
     176                 :      368342 :   return dtype_type_node;
     177                 :             : }
     178                 :             : 
     179                 :             : static int
     180                 :      238992 : get_real_kind_from_node (tree type)
     181                 :             : {
     182                 :      238992 :   int i;
     183                 :             : 
     184                 :      597480 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     185                 :      597480 :     if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
     186                 :      238992 :       return gfc_real_kinds[i].kind;
     187                 :             : 
     188                 :             :   return -4;
     189                 :             : }
     190                 :             : 
     191                 :             : static int
     192                 :      776724 : get_int_kind_from_node (tree type)
     193                 :             : {
     194                 :      776724 :   int i;
     195                 :             : 
     196                 :      776724 :   if (!type)
     197                 :             :     return -2;
     198                 :             : 
     199                 :     2504532 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     200                 :     2504532 :     if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
     201                 :      776724 :       return gfc_integer_kinds[i].kind;
     202                 :             : 
     203                 :             :   return -1;
     204                 :             : }
     205                 :             : 
     206                 :             : static int
     207                 :      477984 : get_int_kind_from_name (const char *name)
     208                 :             : {
     209                 :      477984 :   return get_int_kind_from_node (get_typenode_from_name (name));
     210                 :             : }
     211                 :             : 
     212                 :             : 
     213                 :             : /* Get the kind number corresponding to an integer of given size,
     214                 :             :    following the required return values for ISO_FORTRAN_ENV INT* constants:
     215                 :             :    -2 is returned if we support a kind of larger size, -1 otherwise.  */
     216                 :             : int
     217                 :        3736 : gfc_get_int_kind_from_width_isofortranenv (int size)
     218                 :             : {
     219                 :        3736 :   int i;
     220                 :             : 
     221                 :             :   /* Look for a kind with matching storage size.  */
     222                 :        9340 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     223                 :        9340 :     if (gfc_integer_kinds[i].bit_size == size)
     224                 :        3736 :       return gfc_integer_kinds[i].kind;
     225                 :             : 
     226                 :             :   /* Look for a kind with larger storage size.  */
     227                 :           0 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     228                 :           0 :     if (gfc_integer_kinds[i].bit_size > size)
     229                 :             :       return -2;
     230                 :             : 
     231                 :             :   return -1;
     232                 :             : }
     233                 :             : 
     234                 :             : 
     235                 :             : /* Get the kind number corresponding to a real of a given storage size.
     236                 :             :    If two real's have the same storage size, then choose the real with
     237                 :             :    the largest precision.  If a kind type is unavailable and a real
     238                 :             :    exists with wider storage, then return -2; otherwise, return -1.  */
     239                 :             : 
     240                 :             : int
     241                 :        1868 : gfc_get_real_kind_from_width_isofortranenv (int size)
     242                 :             : {
     243                 :        1868 :   int digits, i, kind;
     244                 :             : 
     245                 :        1868 :   size /= 8;
     246                 :             : 
     247                 :        1868 :   kind = -1;
     248                 :        1868 :   digits = 0;
     249                 :             : 
     250                 :             :   /* Look for a kind with matching storage size.  */
     251                 :        9340 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     252                 :        7472 :     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
     253                 :             :       {
     254                 :        1864 :         if (gfc_real_kinds[i].digits > digits)
     255                 :             :           {
     256                 :        1864 :             digits = gfc_real_kinds[i].digits;
     257                 :        1864 :             kind = gfc_real_kinds[i].kind;
     258                 :             :           }
     259                 :             :       }
     260                 :             : 
     261                 :        1868 :   if (kind != -1)
     262                 :             :     return kind;
     263                 :             : 
     264                 :             :   /* Look for a kind with larger storage size.  */
     265                 :        2335 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     266                 :        1868 :     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
     267                 :        1868 :       kind = -2;
     268                 :             : 
     269                 :             :   return kind;
     270                 :             : }
     271                 :             : 
     272                 :             : 
     273                 :             : 
     274                 :             : static int
     275                 :      149370 : get_int_kind_from_width (int size)
     276                 :             : {
     277                 :      149370 :   int i;
     278                 :             : 
     279                 :      448110 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     280                 :      447296 :     if (gfc_integer_kinds[i].bit_size == size)
     281                 :           0 :       return gfc_integer_kinds[i].kind;
     282                 :             : 
     283                 :             :   return -2;
     284                 :             : }
     285                 :             : 
     286                 :             : static int
     287                 :       29874 : get_int_kind_from_minimal_width (int size)
     288                 :             : {
     289                 :       29874 :   int i;
     290                 :             : 
     291                 :      149370 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     292                 :      148963 :     if (gfc_integer_kinds[i].bit_size >= size)
     293                 :           0 :       return gfc_integer_kinds[i].kind;
     294                 :             : 
     295                 :             :   return -2;
     296                 :             : }
     297                 :             : 
     298                 :             : 
     299                 :             : /* Generate the CInteropKind_t objects for the C interoperable
     300                 :             :    kinds.  */
     301                 :             : 
     302                 :             : void
     303                 :       29874 : gfc_init_c_interop_kinds (void)
     304                 :             : {
     305                 :       29874 :   int i;
     306                 :             : 
     307                 :             :   /* init all pointers in the list to NULL */
     308                 :     1583322 :   for (i = 0; i < ISOCBINDING_NUMBER; i++)
     309                 :             :     {
     310                 :             :       /* Initialize the name and value fields.  */
     311                 :     1553448 :       c_interop_kinds_table[i].name[0] = '\0';
     312                 :     1553448 :       c_interop_kinds_table[i].value = -100;
     313                 :     1553448 :       c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
     314                 :             :     }
     315                 :             : 
     316                 :             : #define NAMED_INTCST(a,b,c,d) \
     317                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     318                 :             :   c_interop_kinds_table[a].f90_type = BT_INTEGER; \
     319                 :             :   c_interop_kinds_table[a].value = c;
     320                 :             : #define NAMED_REALCST(a,b,c,d) \
     321                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     322                 :             :   c_interop_kinds_table[a].f90_type = BT_REAL; \
     323                 :             :   c_interop_kinds_table[a].value = c;
     324                 :             : #define NAMED_CMPXCST(a,b,c,d) \
     325                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     326                 :             :   c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
     327                 :             :   c_interop_kinds_table[a].value = c;
     328                 :             : #define NAMED_LOGCST(a,b,c) \
     329                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     330                 :             :   c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
     331                 :             :   c_interop_kinds_table[a].value = c;
     332                 :             : #define NAMED_CHARKNDCST(a,b,c) \
     333                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     334                 :             :   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
     335                 :             :   c_interop_kinds_table[a].value = c;
     336                 :             : #define NAMED_CHARCST(a,b,c) \
     337                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     338                 :             :   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
     339                 :             :   c_interop_kinds_table[a].value = c;
     340                 :             : #define DERIVED_TYPE(a,b,c) \
     341                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     342                 :             :   c_interop_kinds_table[a].f90_type = BT_DERIVED; \
     343                 :             :   c_interop_kinds_table[a].value = c;
     344                 :             : #define NAMED_FUNCTION(a,b,c,d) \
     345                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     346                 :             :   c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
     347                 :             :   c_interop_kinds_table[a].value = c;
     348                 :             : #define NAMED_SUBROUTINE(a,b,c,d) \
     349                 :             :   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
     350                 :             :   c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
     351                 :             :   c_interop_kinds_table[a].value = c;
     352                 :             : #include "iso-c-binding.def"
     353                 :       29874 : }
     354                 :             : 
     355                 :             : 
     356                 :             : /* Query the target to determine which machine modes are available for
     357                 :             :    computation.  Choose KIND numbers for them.  */
     358                 :             : 
     359                 :             : void
     360                 :       29874 : gfc_init_kinds (void)
     361                 :             : {
     362                 :       29874 :   opt_scalar_int_mode int_mode_iter;
     363                 :       29874 :   opt_scalar_float_mode float_mode_iter;
     364                 :       29874 :   int i_index, r_index, kind;
     365                 :       29874 :   bool saw_i4 = false, saw_i8 = false;
     366                 :       29874 :   bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
     367                 :       29874 :   scalar_mode r16_mode = QImode;
     368                 :       29874 :   scalar_mode composite_mode = QImode;
     369                 :             : 
     370                 :       29874 :   i_index = 0;
     371                 :      238992 :   FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
     372                 :             :     {
     373                 :      209118 :       scalar_int_mode mode = int_mode_iter.require ();
     374                 :      209118 :       int kind, bitsize;
     375                 :             : 
     376                 :      209118 :       if (!targetm.scalar_mode_supported_p (mode))
     377                 :      209118 :         continue;
     378                 :             : 
     379                 :             :       /* The middle end doesn't support constants larger than 2*HWI.
     380                 :             :          Perhaps the target hook shouldn't have accepted these either,
     381                 :             :          but just to be safe...  */
     382                 :      148963 :       bitsize = GET_MODE_BITSIZE (mode);
     383                 :      148963 :       if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
     384                 :           0 :         continue;
     385                 :             : 
     386                 :      148963 :       gcc_assert (i_index != MAX_INT_KINDS);
     387                 :             : 
     388                 :             :       /* Let the kind equal the bit size divided by 8.  This insulates the
     389                 :             :          programmer from the underlying byte size.  */
     390                 :      148963 :       kind = bitsize / 8;
     391                 :             : 
     392                 :      148963 :       if (kind == 4)
     393                 :             :         saw_i4 = true;
     394                 :      119089 :       if (kind == 8)
     395                 :       29874 :         saw_i8 = true;
     396                 :             : 
     397                 :      148963 :       gfc_integer_kinds[i_index].kind = kind;
     398                 :      148963 :       gfc_integer_kinds[i_index].radix = 2;
     399                 :      148963 :       gfc_integer_kinds[i_index].digits = bitsize - 1;
     400                 :      148963 :       gfc_integer_kinds[i_index].bit_size = bitsize;
     401                 :             : 
     402                 :      148963 :       gfc_logical_kinds[i_index].kind = kind;
     403                 :      148963 :       gfc_logical_kinds[i_index].bit_size = bitsize;
     404                 :             : 
     405                 :      148963 :       i_index += 1;
     406                 :             :     }
     407                 :             : 
     408                 :             :   /* Set the kind used to match GFC_INT_IO in libgfortran.  This is
     409                 :             :      used for large file access.  */
     410                 :             : 
     411                 :       29874 :   if (saw_i8)
     412                 :       29874 :     gfc_intio_kind = 8;
     413                 :             :   else
     414                 :           0 :     gfc_intio_kind = 4;
     415                 :             : 
     416                 :             :   /* If we do not at least have kind = 4, everything is pointless.  */
     417                 :       29874 :   gcc_assert(saw_i4);
     418                 :             : 
     419                 :             :   /* Set the maximum integer kind.  Used with at least BOZ constants.  */
     420                 :       29874 :   gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
     421                 :             : 
     422                 :       29874 :   r_index = 0;
     423                 :      209118 :   FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
     424                 :             :     {
     425                 :      179244 :       scalar_float_mode mode = float_mode_iter.require ();
     426                 :      179244 :       const struct real_format *fmt = REAL_MODE_FORMAT (mode);
     427                 :      179244 :       int kind;
     428                 :             : 
     429                 :      179244 :       if (fmt == NULL)
     430                 :      179244 :         continue;
     431                 :      179244 :       if (!targetm.scalar_mode_supported_p (mode))
     432                 :           0 :         continue;
     433                 :             : 
     434                 :     1254708 :       if (MODE_COMPOSITE_P (mode)
     435                 :           0 :           && (GET_MODE_PRECISION (mode) + 7) / 8 == 16)
     436                 :           0 :         composite_mode = mode;
     437                 :             : 
     438                 :             :       /* Only let float, double, long double and TFmode go through.
     439                 :             :          Runtime support for others is not provided, so they would be
     440                 :             :          useless.  */
     441                 :      179244 :       if (!targetm.libgcc_floating_mode_supported_p (mode))
     442                 :           0 :         continue;
     443                 :      179244 :       if (mode != TYPE_MODE (float_type_node)
     444                 :      149370 :             && (mode != TYPE_MODE (double_type_node))
     445                 :      119496 :             && (mode != TYPE_MODE (long_double_type_node))
     446                 :             : #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
     447                 :      268866 :             && (mode != TFmode)
     448                 :             : #endif
     449                 :             :            )
     450                 :       59748 :         continue;
     451                 :             : 
     452                 :             :       /* Let the kind equal the precision divided by 8, rounding up.  Again,
     453                 :             :          this insulates the programmer from the underlying byte size.
     454                 :             : 
     455                 :             :          Also, it effectively deals with IEEE extended formats.  There, the
     456                 :             :          total size of the type may equal 16, but it's got 6 bytes of padding
     457                 :             :          and the increased size can get in the way of a real IEEE quad format
     458                 :             :          which may also be supported by the target.
     459                 :             : 
     460                 :             :          We round up so as to handle IA-64 __floatreg (RFmode), which is an
     461                 :             :          82 bit type.  Not to be confused with __float80 (XFmode), which is
     462                 :             :          an 80 bit type also supported by IA-64.  So XFmode should come out
     463                 :             :          to be kind=10, and RFmode should come out to be kind=11.  Egads.
     464                 :             : 
     465                 :             :          TODO: The kind calculation has to be modified to support all
     466                 :             :          three 128-bit floating-point modes on PowerPC as IFmode, KFmode,
     467                 :             :          and TFmode since the following line would all map to kind=16.
     468                 :             :          However, currently only float, double, long double, and TFmode
     469                 :             :          reach this code.
     470                 :             :       */
     471                 :             : 
     472                 :      119496 :       kind = (GET_MODE_PRECISION (mode) + 7) / 8;
     473                 :             : 
     474                 :      119496 :       if (kind == 4)
     475                 :             :         saw_r4 = true;
     476                 :       89622 :       if (kind == 8)
     477                 :             :         saw_r8 = true;
     478                 :       89622 :       if (kind == 10)
     479                 :             :         saw_r10 = true;
     480                 :       89622 :       if (kind == 16)
     481                 :             :         {
     482                 :       29874 :           saw_r16 = true;
     483                 :       29874 :           r16_mode = mode;
     484                 :             :         }
     485                 :             : 
     486                 :             :       /* Careful we don't stumble a weird internal mode.  */
     487                 :      119496 :       gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
     488                 :             :       /* Or have too many modes for the allocated space.  */
     489                 :       89622 :       gcc_assert (r_index != MAX_REAL_KINDS);
     490                 :             : 
     491                 :      119496 :       gfc_real_kinds[r_index].kind = kind;
     492                 :      119496 :       gfc_real_kinds[r_index].abi_kind = kind;
     493                 :      119496 :       gfc_real_kinds[r_index].radix = fmt->b;
     494                 :      119496 :       gfc_real_kinds[r_index].digits = fmt->p;
     495                 :      119496 :       gfc_real_kinds[r_index].min_exponent = fmt->emin;
     496                 :      119496 :       gfc_real_kinds[r_index].max_exponent = fmt->emax;
     497                 :      119496 :       if (fmt->pnan < fmt->p)
     498                 :             :         /* This is an IBM extended double format (or the MIPS variant)
     499                 :             :            made up of two IEEE doubles.  The value of the long double is
     500                 :             :            the sum of the values of the two parts.  The most significant
     501                 :             :            part is required to be the value of the long double rounded
     502                 :             :            to the nearest double.  If we use emax of 1024 then we can't
     503                 :             :            represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
     504                 :             :            rounding will make the most significant part overflow.  */
     505                 :           0 :         gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
     506                 :      119496 :       gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
     507                 :      119496 :       r_index += 1;
     508                 :             :     }
     509                 :             : 
     510                 :             :   /* Detect the powerpc64le-linux case with -mabi=ieeelongdouble, where
     511                 :             :      the long double type is non-MODE_COMPOSITE_P TFmode but one can use
     512                 :             :      -mabi=ibmlongdouble too and get MODE_COMPOSITE_P TFmode with the same
     513                 :             :      precision.  For libgfortran calls pretend the IEEE 754 quad TFmode has
     514                 :             :      kind 17 rather than 16 and use kind 16 for the IBM extended format
     515                 :             :      TFmode.  */
     516                 :       29874 :   if (composite_mode != QImode && saw_r16 && !MODE_COMPOSITE_P (r16_mode))
     517                 :             :     {
     518                 :           0 :       for (int i = 0; i < r_index; ++i)
     519                 :           0 :         if (gfc_real_kinds[i].kind == 16)
     520                 :             :           {
     521                 :           0 :             gfc_real_kinds[i].abi_kind = 17;
     522                 :           0 :             if (flag_building_libgfortran
     523                 :             :                 && (TARGET_GLIBC_MAJOR < 2
     524                 :             :                     || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32)))
     525                 :             :               {
     526                 :             :                 if (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26)
     527                 :             :                   {
     528                 :             :                     gfc_real16_use_iec_60559 = true;
     529                 :             :                     gfc_real_kinds[i].use_iec_60559 = 1;
     530                 :             :                   }
     531                 :             :                 gfc_real16_is_float128 = true;
     532                 :             :                 gfc_real_kinds[i].c_float128 = 1;
     533                 :             :               }
     534                 :             :           }
     535                 :             :     }
     536                 :       29874 :   else if ((flag_convert & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM)) != 0)
     537                 :           0 :     gfc_fatal_error ("%<-fconvert=r16_ieee%> or %<-fconvert=r16_ibm%> not "
     538                 :             :                      "supported on this architecture");
     539                 :             : 
     540                 :             :   /* Choose the default integer kind.  We choose 4 unless the user directs us
     541                 :             :      otherwise.  Even if the user specified that the default integer kind is 8,
     542                 :             :      the numeric storage size is not 64 bits.  In this case, a warning will be
     543                 :             :      issued when NUMERIC_STORAGE_SIZE is used.  Set NUMERIC_STORAGE_SIZE to 32.  */
     544                 :             : 
     545                 :       29874 :   gfc_numeric_storage_size = 4 * 8;
     546                 :             : 
     547                 :       29874 :   if (flag_default_integer)
     548                 :             :     {
     549                 :          98 :       if (!saw_i8)
     550                 :           0 :         gfc_fatal_error ("INTEGER(KIND=8) is not available for "
     551                 :             :                          "%<-fdefault-integer-8%> option");
     552                 :             : 
     553                 :          98 :       gfc_default_integer_kind = 8;
     554                 :             : 
     555                 :             :     }
     556                 :       29776 :   else if (flag_integer4_kind == 8)
     557                 :             :     {
     558                 :           0 :       if (!saw_i8)
     559                 :           0 :         gfc_fatal_error ("INTEGER(KIND=8) is not available for "
     560                 :             :                          "%<-finteger-4-integer-8%> option");
     561                 :             : 
     562                 :           0 :       gfc_default_integer_kind = 8;
     563                 :             :     }
     564                 :       29776 :   else if (saw_i4)
     565                 :             :     {
     566                 :       29776 :       gfc_default_integer_kind = 4;
     567                 :             :     }
     568                 :             :   else
     569                 :             :     {
     570                 :             :       gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
     571                 :             :       gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
     572                 :             :     }
     573                 :             : 
     574                 :             :   /* Choose the default real kind.  Again, we choose 4 when possible.  */
     575                 :       29874 :   if (flag_default_real_8)
     576                 :             :     {
     577                 :           2 :       if (!saw_r8)
     578                 :           0 :         gfc_fatal_error ("REAL(KIND=8) is not available for "
     579                 :             :                          "%<-fdefault-real-8%> option");
     580                 :             : 
     581                 :           2 :       gfc_default_real_kind = 8;
     582                 :             :     }
     583                 :       29872 :   else if (flag_default_real_10)
     584                 :             :   {
     585                 :           6 :     if (!saw_r10)
     586                 :           0 :       gfc_fatal_error ("REAL(KIND=10) is not available for "
     587                 :             :                         "%<-fdefault-real-10%> option");
     588                 :             : 
     589                 :           6 :     gfc_default_real_kind = 10;
     590                 :             :   }
     591                 :       29866 :   else if (flag_default_real_16)
     592                 :             :   {
     593                 :           6 :     if (!saw_r16)
     594                 :           0 :       gfc_fatal_error ("REAL(KIND=16) is not available for "
     595                 :             :                         "%<-fdefault-real-16%> option");
     596                 :             : 
     597                 :           6 :     gfc_default_real_kind = 16;
     598                 :             :   }
     599                 :       29860 :   else if (flag_real4_kind == 8)
     600                 :             :   {
     601                 :          24 :     if (!saw_r8)
     602                 :           0 :       gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
     603                 :             :                        "option");
     604                 :             : 
     605                 :          24 :     gfc_default_real_kind = 8;
     606                 :             :   }
     607                 :       29836 :   else if (flag_real4_kind == 10)
     608                 :             :   {
     609                 :          24 :     if (!saw_r10)
     610                 :           0 :       gfc_fatal_error ("REAL(KIND=10) is not available for "
     611                 :             :                        "%<-freal-4-real-10%> option");
     612                 :             : 
     613                 :          24 :     gfc_default_real_kind = 10;
     614                 :             :   }
     615                 :       29812 :   else if (flag_real4_kind == 16)
     616                 :             :   {
     617                 :          24 :     if (!saw_r16)
     618                 :           0 :       gfc_fatal_error ("REAL(KIND=16) is not available for "
     619                 :             :                        "%<-freal-4-real-16%> option");
     620                 :             : 
     621                 :          24 :     gfc_default_real_kind = 16;
     622                 :             :   }
     623                 :       29788 :   else if (saw_r4)
     624                 :       29788 :     gfc_default_real_kind = 4;
     625                 :             :   else
     626                 :           0 :     gfc_default_real_kind = gfc_real_kinds[0].kind;
     627                 :             : 
     628                 :             :   /* Choose the default double kind.  If -fdefault-real and -fdefault-double
     629                 :             :      are specified, we use kind=8, if it's available.  If -fdefault-real is
     630                 :             :      specified without -fdefault-double, we use kind=16, if it's available.
     631                 :             :      Otherwise we do not change anything.  */
     632                 :       29874 :   if (flag_default_double && saw_r8)
     633                 :           0 :     gfc_default_double_kind = 8;
     634                 :       29874 :   else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16)
     635                 :             :     {
     636                 :             :       /* Use largest available kind.  */
     637                 :          14 :       if (saw_r16)
     638                 :          14 :         gfc_default_double_kind = 16;
     639                 :           0 :       else if (saw_r10)
     640                 :           0 :         gfc_default_double_kind = 10;
     641                 :           0 :       else if (saw_r8)
     642                 :           0 :         gfc_default_double_kind = 8;
     643                 :             :       else
     644                 :           0 :         gfc_default_double_kind = gfc_default_real_kind;
     645                 :             :     }
     646                 :       29860 :   else if (flag_real8_kind == 4)
     647                 :             :     {
     648                 :          24 :       if (!saw_r4)
     649                 :           0 :         gfc_fatal_error ("REAL(KIND=4) is not available for "
     650                 :             :                          "%<-freal-8-real-4%> option");
     651                 :             : 
     652                 :          24 :       gfc_default_double_kind = 4;
     653                 :             :     }
     654                 :       29836 :   else if (flag_real8_kind == 10 )
     655                 :             :     {
     656                 :          24 :       if (!saw_r10)
     657                 :           0 :         gfc_fatal_error ("REAL(KIND=10) is not available for "
     658                 :             :                          "%<-freal-8-real-10%> option");
     659                 :             : 
     660                 :          24 :       gfc_default_double_kind = 10;
     661                 :             :     }
     662                 :       29812 :   else if (flag_real8_kind == 16 )
     663                 :             :     {
     664                 :          24 :       if (!saw_r16)
     665                 :           0 :         gfc_fatal_error ("REAL(KIND=10) is not available for "
     666                 :             :                          "%<-freal-8-real-16%> option");
     667                 :             : 
     668                 :          24 :       gfc_default_double_kind = 16;
     669                 :             :     }
     670                 :       29788 :   else if (saw_r4 && saw_r8)
     671                 :       29788 :     gfc_default_double_kind = 8;
     672                 :             :   else
     673                 :             :     {
     674                 :             :       /* F95 14.6.3.1: A nonpointer scalar object of type double precision
     675                 :             :          real ... occupies two contiguous numeric storage units.
     676                 :             : 
     677                 :             :          Therefore we must be supplied a kind twice as large as we chose
     678                 :             :          for single precision.  There are loopholes, in that double
     679                 :             :          precision must *occupy* two storage units, though it doesn't have
     680                 :             :          to *use* two storage units.  Which means that you can make this
     681                 :             :          kind artificially wide by padding it.  But at present there are
     682                 :             :          no GCC targets for which a two-word type does not exist, so we
     683                 :             :          just let gfc_validate_kind abort and tell us if something breaks.  */
     684                 :             : 
     685                 :           0 :       gfc_default_double_kind
     686                 :           0 :         = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
     687                 :             :     }
     688                 :             : 
     689                 :             :   /* The default logical kind is constrained to be the same as the
     690                 :             :      default integer kind.  Similarly with complex and real.  */
     691                 :       29874 :   gfc_default_logical_kind = gfc_default_integer_kind;
     692                 :       29874 :   gfc_default_complex_kind = gfc_default_real_kind;
     693                 :             : 
     694                 :             :   /* We only have two character kinds: ASCII and UCS-4.
     695                 :             :      ASCII corresponds to a 8-bit integer type, if one is available.
     696                 :             :      UCS-4 corresponds to a 32-bit integer type, if one is available.  */
     697                 :       29874 :   i_index = 0;
     698                 :       59748 :   if ((kind = get_int_kind_from_width (8)) > 0)
     699                 :             :     {
     700                 :       29874 :       gfc_character_kinds[i_index].kind = kind;
     701                 :       29874 :       gfc_character_kinds[i_index].bit_size = 8;
     702                 :       29874 :       gfc_character_kinds[i_index].name = "ascii";
     703                 :       29874 :       i_index++;
     704                 :             :     }
     705                 :       59748 :   if ((kind = get_int_kind_from_width (32)) > 0)
     706                 :             :     {
     707                 :       29874 :       gfc_character_kinds[i_index].kind = kind;
     708                 :       29874 :       gfc_character_kinds[i_index].bit_size = 32;
     709                 :       29874 :       gfc_character_kinds[i_index].name = "iso_10646";
     710                 :       29874 :       i_index++;
     711                 :             :     }
     712                 :             : 
     713                 :             :   /* Choose the smallest integer kind for our default character.  */
     714                 :       29874 :   gfc_default_character_kind = gfc_character_kinds[0].kind;
     715                 :       29874 :   gfc_character_storage_size = gfc_default_character_kind * 8;
     716                 :             : 
     717                 :       30281 :   gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
     718                 :             : 
     719                 :             :   /* Pick a kind the same size as the C "int" type.  */
     720                 :       29874 :   gfc_c_int_kind = INT_TYPE_SIZE / 8;
     721                 :             : 
     722                 :             :   /* Choose atomic kinds to match C's int.  */
     723                 :       29874 :   gfc_atomic_int_kind = gfc_c_int_kind;
     724                 :       29874 :   gfc_atomic_logical_kind = gfc_c_int_kind;
     725                 :             : 
     726                 :       29874 :   gfc_c_intptr_kind = POINTER_SIZE / 8;
     727                 :       29874 : }
     728                 :             : 
     729                 :             : 
     730                 :             : /* Make sure that a valid kind is present.  Returns an index into the
     731                 :             :    associated kinds array, -1 if the kind is not present.  */
     732                 :             : 
     733                 :             : static int
     734                 :           0 : validate_integer (int kind)
     735                 :             : {
     736                 :           0 :   int i;
     737                 :             : 
     738                 :    74800688 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     739                 :    74798633 :     if (gfc_integer_kinds[i].kind == kind)
     740                 :           0 :       return i;
     741                 :             : 
     742                 :             :   return -1;
     743                 :             : }
     744                 :             : 
     745                 :             : static int
     746                 :           0 : validate_real (int kind)
     747                 :             : {
     748                 :           0 :   int i;
     749                 :             : 
     750                 :     4819064 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     751                 :     4819054 :     if (gfc_real_kinds[i].kind == kind)
     752                 :           0 :       return i;
     753                 :             : 
     754                 :             :   return -1;
     755                 :             : }
     756                 :             : 
     757                 :             : static int
     758                 :           0 : validate_logical (int kind)
     759                 :             : {
     760                 :           0 :   int i;
     761                 :             : 
     762                 :     1423916 :   for (i = 0; gfc_logical_kinds[i].kind; i++)
     763                 :     1423908 :     if (gfc_logical_kinds[i].kind == kind)
     764                 :           0 :       return i;
     765                 :             : 
     766                 :             :   return -1;
     767                 :             : }
     768                 :             : 
     769                 :             : static int
     770                 :           0 : validate_character (int kind)
     771                 :             : {
     772                 :           0 :   int i;
     773                 :             : 
     774                 :     1317347 :   for (i = 0; gfc_character_kinds[i].kind; i++)
     775                 :     1317333 :     if (gfc_character_kinds[i].kind == kind)
     776                 :           0 :       return i;
     777                 :             : 
     778                 :             :   return -1;
     779                 :             : }
     780                 :             : 
     781                 :             : /* Validate a kind given a basic type.  The return value is the same
     782                 :             :    for the child functions, with -1 indicating nonexistence of the
     783                 :             :    type.  If MAY_FAIL is false, then -1 is never returned, and we ICE.  */
     784                 :             : 
     785                 :             : int
     786                 :    28205307 : gfc_validate_kind (bt type, int kind, bool may_fail)
     787                 :             : {
     788                 :    28205307 :   int rc;
     789                 :             : 
     790                 :    28205307 :   switch (type)
     791                 :             :     {
     792                 :             :     case BT_REAL:               /* Fall through */
     793                 :             :     case BT_COMPLEX:
     794                 :    28205307 :       rc = validate_real (kind);
     795                 :             :       break;
     796                 :             :     case BT_INTEGER:
     797                 :    28205307 :       rc = validate_integer (kind);
     798                 :             :       break;
     799                 :             :     case BT_LOGICAL:
     800                 :    28205307 :       rc = validate_logical (kind);
     801                 :             :       break;
     802                 :             :     case BT_CHARACTER:
     803                 :    28205307 :       rc = validate_character (kind);
     804                 :             :       break;
     805                 :             : 
     806                 :           0 :     default:
     807                 :           0 :       gfc_internal_error ("gfc_validate_kind(): Got bad type");
     808                 :             :     }
     809                 :             : 
     810                 :    28205307 :   if (rc < 0 && !may_fail)
     811                 :           0 :     gfc_internal_error ("gfc_validate_kind(): Got bad kind");
     812                 :             : 
     813                 :    28205307 :   return rc;
     814                 :             : }
     815                 :             : 
     816                 :             : 
     817                 :             : /* Four subroutines of gfc_init_types.  Create type nodes for the given kind.
     818                 :             :    Reuse common type nodes where possible.  Recognize if the kind matches up
     819                 :             :    with a C type.  This will be used later in determining which routines may
     820                 :             :    be scarfed from libm.  */
     821                 :             : 
     822                 :             : static tree
     823                 :      148963 : gfc_build_int_type (gfc_integer_info *info)
     824                 :             : {
     825                 :      148963 :   int mode_precision = info->bit_size;
     826                 :             : 
     827                 :      148963 :   if (mode_precision == CHAR_TYPE_SIZE)
     828                 :       29874 :     info->c_char = 1;
     829                 :      148963 :   if (mode_precision == SHORT_TYPE_SIZE)
     830                 :       29874 :     info->c_short = 1;
     831                 :      148963 :   if (mode_precision == INT_TYPE_SIZE)
     832                 :       29874 :     info->c_int = 1;
     833                 :      150591 :   if (mode_precision == LONG_TYPE_SIZE)
     834                 :       29874 :     info->c_long = 1;
     835                 :      148963 :   if (mode_precision == LONG_LONG_TYPE_SIZE)
     836                 :       29874 :     info->c_long_long = 1;
     837                 :             : 
     838                 :      148963 :   if (TYPE_PRECISION (intQI_type_node) == mode_precision)
     839                 :             :     return intQI_type_node;
     840                 :      119089 :   if (TYPE_PRECISION (intHI_type_node) == mode_precision)
     841                 :             :     return intHI_type_node;
     842                 :       89215 :   if (TYPE_PRECISION (intSI_type_node) == mode_precision)
     843                 :             :     return intSI_type_node;
     844                 :       59341 :   if (TYPE_PRECISION (intDI_type_node) == mode_precision)
     845                 :             :     return intDI_type_node;
     846                 :       29467 :   if (TYPE_PRECISION (intTI_type_node) == mode_precision)
     847                 :             :     return intTI_type_node;
     848                 :             : 
     849                 :           0 :   return make_signed_type (mode_precision);
     850                 :             : }
     851                 :             : 
     852                 :             : tree
     853                 :       60494 : gfc_build_uint_type (int size)
     854                 :             : {
     855                 :       60494 :   if (size == CHAR_TYPE_SIZE)
     856                 :       30000 :     return unsigned_char_type_node;
     857                 :       30494 :   if (size == SHORT_TYPE_SIZE)
     858                 :         126 :     return short_unsigned_type_node;
     859                 :       30368 :   if (size == INT_TYPE_SIZE)
     860                 :       30108 :     return unsigned_type_node;
     861                 :         260 :   if (size == LONG_TYPE_SIZE)
     862                 :         126 :     return long_unsigned_type_node;
     863                 :         134 :   if (size == LONG_LONG_TYPE_SIZE)
     864                 :           0 :     return long_long_unsigned_type_node;
     865                 :             : 
     866                 :         134 :   return make_unsigned_type (size);
     867                 :             : }
     868                 :             : 
     869                 :             : 
     870                 :             : static tree
     871                 :      119496 : gfc_build_real_type (gfc_real_info *info)
     872                 :             : {
     873                 :      119496 :   int mode_precision = info->mode_precision;
     874                 :      119496 :   tree new_type;
     875                 :             : 
     876                 :      119496 :   if (mode_precision == TYPE_PRECISION (float_type_node))
     877                 :       29874 :     info->c_float = 1;
     878                 :      119496 :   if (mode_precision == TYPE_PRECISION (double_type_node))
     879                 :       29874 :     info->c_double = 1;
     880                 :      119496 :   if (mode_precision == TYPE_PRECISION (long_double_type_node)
     881                 :      119496 :       && !info->c_float128)
     882                 :       29874 :     info->c_long_double = 1;
     883                 :      119496 :   if (mode_precision != TYPE_PRECISION (long_double_type_node)
     884                 :      119496 :       && mode_precision == 128)
     885                 :             :     {
     886                 :             :       /* TODO: see PR101835.  */
     887                 :       29874 :       info->c_float128 = 1;
     888                 :       29874 :       gfc_real16_is_float128 = true;
     889                 :       29874 :       if (TARGET_GLIBC_MAJOR > 2
     890                 :             :           || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26))
     891                 :             :         {
     892                 :       29874 :           info->use_iec_60559 = 1;
     893                 :       29874 :           gfc_real16_use_iec_60559 = true;
     894                 :             :         }
     895                 :             :     }
     896                 :             : 
     897                 :      119496 :   if (TYPE_PRECISION (float_type_node) == mode_precision)
     898                 :             :     return float_type_node;
     899                 :       89622 :   if (TYPE_PRECISION (double_type_node) == mode_precision)
     900                 :             :     return double_type_node;
     901                 :       59748 :   if (TYPE_PRECISION (long_double_type_node) == mode_precision)
     902                 :             :     return long_double_type_node;
     903                 :             : 
     904                 :       29874 :   new_type = make_node (REAL_TYPE);
     905                 :       29874 :   TYPE_PRECISION (new_type) = mode_precision;
     906                 :       29874 :   layout_type (new_type);
     907                 :       29874 :   return new_type;
     908                 :             : }
     909                 :             : 
     910                 :             : static tree
     911                 :      119496 : gfc_build_complex_type (tree scalar_type)
     912                 :             : {
     913                 :      119496 :   tree new_type;
     914                 :             : 
     915                 :      119496 :   if (scalar_type == NULL)
     916                 :             :     return NULL;
     917                 :      119496 :   if (scalar_type == float_type_node)
     918                 :       29874 :     return complex_float_type_node;
     919                 :       89622 :   if (scalar_type == double_type_node)
     920                 :       29874 :     return complex_double_type_node;
     921                 :       59748 :   if (scalar_type == long_double_type_node)
     922                 :       29874 :     return complex_long_double_type_node;
     923                 :             : 
     924                 :       29874 :   new_type = make_node (COMPLEX_TYPE);
     925                 :       29874 :   TREE_TYPE (new_type) = scalar_type;
     926                 :       29874 :   layout_type (new_type);
     927                 :       29874 :   return new_type;
     928                 :             : }
     929                 :             : 
     930                 :             : static tree
     931                 :      148963 : gfc_build_logical_type (gfc_logical_info *info)
     932                 :             : {
     933                 :      148963 :   int bit_size = info->bit_size;
     934                 :      148963 :   tree new_type;
     935                 :             : 
     936                 :      148963 :   if (bit_size == BOOL_TYPE_SIZE)
     937                 :             :     {
     938                 :       29874 :       info->c_bool = 1;
     939                 :       29874 :       return boolean_type_node;
     940                 :             :     }
     941                 :             : 
     942                 :      119089 :   new_type = make_unsigned_type (bit_size);
     943                 :      119089 :   TREE_SET_CODE (new_type, BOOLEAN_TYPE);
     944                 :      119089 :   TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
     945                 :      119089 :   TYPE_PRECISION (new_type) = 1;
     946                 :             : 
     947                 :      119089 :   return new_type;
     948                 :             : }
     949                 :             : 
     950                 :             : 
     951                 :             : /* Create the backend type nodes. We map them to their
     952                 :             :    equivalent C type, at least for now.  We also give
     953                 :             :    names to the types here, and we push them in the
     954                 :             :    global binding level context.*/
     955                 :             : 
     956                 :             : void
     957                 :       29874 : gfc_init_types (void)
     958                 :             : {
     959                 :       29874 :   char name_buf[26];
     960                 :       29874 :   int index;
     961                 :       29874 :   tree type;
     962                 :       29874 :   unsigned n;
     963                 :             : 
     964                 :             :   /* Create and name the types.  */
     965                 :             : #define PUSH_TYPE(name, node) \
     966                 :             :   pushdecl (build_decl (input_location, \
     967                 :             :                         TYPE_DECL, get_identifier (name), node))
     968                 :             : 
     969                 :      178837 :   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
     970                 :             :     {
     971                 :      148963 :       type = gfc_build_int_type (&gfc_integer_kinds[index]);
     972                 :             :       /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
     973                 :      148963 :       if (TYPE_STRING_FLAG (type))
     974                 :       29874 :         type = make_signed_type (gfc_integer_kinds[index].bit_size);
     975                 :      148963 :       gfc_integer_types[index] = type;
     976                 :      148963 :       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
     977                 :             :                 gfc_integer_kinds[index].kind);
     978                 :      148963 :       PUSH_TYPE (name_buf, type);
     979                 :             :     }
     980                 :             : 
     981                 :      178837 :   for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
     982                 :             :     {
     983                 :      148963 :       type = gfc_build_logical_type (&gfc_logical_kinds[index]);
     984                 :      148963 :       gfc_logical_types[index] = type;
     985                 :      148963 :       snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
     986                 :             :                 gfc_logical_kinds[index].kind);
     987                 :      148963 :       PUSH_TYPE (name_buf, type);
     988                 :             :     }
     989                 :             : 
     990                 :      149370 :   for (index = 0; gfc_real_kinds[index].kind != 0; index++)
     991                 :             :     {
     992                 :      119496 :       type = gfc_build_real_type (&gfc_real_kinds[index]);
     993                 :      119496 :       gfc_real_types[index] = type;
     994                 :      119496 :       snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
     995                 :             :                 gfc_real_kinds[index].kind);
     996                 :      119496 :       PUSH_TYPE (name_buf, type);
     997                 :             : 
     998                 :      119496 :       if (gfc_real_kinds[index].c_float128)
     999                 :       29874 :         gfc_float128_type_node = type;
    1000                 :             : 
    1001                 :      119496 :       type = gfc_build_complex_type (type);
    1002                 :      119496 :       gfc_complex_types[index] = type;
    1003                 :      119496 :       snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
    1004                 :             :                 gfc_real_kinds[index].kind);
    1005                 :      119496 :       PUSH_TYPE (name_buf, type);
    1006                 :             : 
    1007                 :      119496 :       if (gfc_real_kinds[index].c_float128)
    1008                 :       29874 :         gfc_complex_float128_type_node = type;
    1009                 :             :     }
    1010                 :             : 
    1011                 :       89622 :   for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
    1012                 :             :     {
    1013                 :       59748 :       type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
    1014                 :       59748 :       type = build_qualified_type (type, TYPE_UNQUALIFIED);
    1015                 :       59748 :       snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
    1016                 :             :                 gfc_character_kinds[index].kind);
    1017                 :       59748 :       PUSH_TYPE (name_buf, type);
    1018                 :       59748 :       gfc_character_types[index] = type;
    1019                 :       59748 :       gfc_pcharacter_types[index] = build_pointer_type (type);
    1020                 :             :     }
    1021                 :       29874 :   gfc_character1_type_node = gfc_character_types[0];
    1022                 :             : 
    1023                 :       29874 :   PUSH_TYPE ("byte", unsigned_char_type_node);
    1024                 :       29874 :   PUSH_TYPE ("void", void_type_node);
    1025                 :             : 
    1026                 :             :   /* DBX debugging output gets upset if these aren't set.  */
    1027                 :       29874 :   if (!TYPE_NAME (integer_type_node))
    1028                 :           0 :     PUSH_TYPE ("c_integer", integer_type_node);
    1029                 :       29874 :   if (!TYPE_NAME (char_type_node))
    1030                 :       29874 :     PUSH_TYPE ("c_char", char_type_node);
    1031                 :             : 
    1032                 :             : #undef PUSH_TYPE
    1033                 :             : 
    1034                 :       29874 :   pvoid_type_node = build_pointer_type (void_type_node);
    1035                 :       29874 :   prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
    1036                 :       29874 :   ppvoid_type_node = build_pointer_type (pvoid_type_node);
    1037                 :       29874 :   pchar_type_node = build_pointer_type (gfc_character1_type_node);
    1038                 :       29874 :   pfunc_type_node
    1039                 :       29874 :     = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
    1040                 :             : 
    1041                 :       29874 :   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
    1042                 :             :   /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
    1043                 :             :      since this function is called before gfc_init_constants.  */
    1044                 :       29874 :   gfc_array_range_type
    1045                 :       29874 :           = build_range_type (gfc_array_index_type,
    1046                 :       29874 :                               build_int_cst (gfc_array_index_type, 0),
    1047                 :             :                               NULL_TREE);
    1048                 :             : 
    1049                 :             :   /* The maximum array element size that can be handled is determined
    1050                 :             :      by the number of bits available to store this field in the array
    1051                 :             :      descriptor.  */
    1052                 :             : 
    1053                 :       29874 :   n = TYPE_PRECISION (size_type_node);
    1054                 :       29874 :   gfc_max_array_element_size
    1055                 :       29874 :     = wide_int_to_tree (size_type_node,
    1056                 :       29874 :                         wi::mask (n, UNSIGNED,
    1057                 :       29874 :                                   TYPE_PRECISION (size_type_node)));
    1058                 :             : 
    1059                 :       29874 :   logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
    1060                 :       29874 :   logical_true_node = build_int_cst (logical_type_node, 1);
    1061                 :       29874 :   logical_false_node = build_int_cst (logical_type_node, 0);
    1062                 :             : 
    1063                 :             :   /* Character lengths are of type size_t, except signed.  */
    1064                 :       29874 :   gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
    1065                 :       29874 :   gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
    1066                 :             : 
    1067                 :             :   /* Fortran kind number of size_type_node (size_t). This is used for
    1068                 :             :      the _size member in vtables.  */
    1069                 :       29874 :   gfc_size_kind = get_int_kind_from_node (size_type_node);
    1070                 :       29874 : }
    1071                 :             : 
    1072                 :             : /* Get the type node for the given type and kind.  */
    1073                 :             : 
    1074                 :             : tree
    1075                 :     4842453 : gfc_get_int_type (int kind)
    1076                 :             : {
    1077                 :     4842453 :   int index = gfc_validate_kind (BT_INTEGER, kind, true);
    1078                 :     4842453 :   return index < 0 ? 0 : gfc_integer_types[index];
    1079                 :             : }
    1080                 :             : 
    1081                 :             : tree
    1082                 :      691638 : gfc_get_real_type (int kind)
    1083                 :             : {
    1084                 :      691638 :   int index = gfc_validate_kind (BT_REAL, kind, true);
    1085                 :      691638 :   return index < 0 ? 0 : gfc_real_types[index];
    1086                 :             : }
    1087                 :             : 
    1088                 :             : tree
    1089                 :      443479 : gfc_get_complex_type (int kind)
    1090                 :             : {
    1091                 :      443479 :   int index = gfc_validate_kind (BT_COMPLEX, kind, true);
    1092                 :      443479 :   return index < 0 ? 0 : gfc_complex_types[index];
    1093                 :             : }
    1094                 :             : 
    1095                 :             : tree
    1096                 :      428064 : gfc_get_logical_type (int kind)
    1097                 :             : {
    1098                 :      428064 :   int index = gfc_validate_kind (BT_LOGICAL, kind, true);
    1099                 :      428064 :   return index < 0 ? 0 : gfc_logical_types[index];
    1100                 :             : }
    1101                 :             : 
    1102                 :             : tree
    1103                 :      403698 : gfc_get_char_type (int kind)
    1104                 :             : {
    1105                 :      403698 :   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
    1106                 :      403698 :   return index < 0 ? 0 : gfc_character_types[index];
    1107                 :             : }
    1108                 :             : 
    1109                 :             : tree
    1110                 :      154784 : gfc_get_pchar_type (int kind)
    1111                 :             : {
    1112                 :      154784 :   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
    1113                 :      154784 :   return index < 0 ? 0 : gfc_pcharacter_types[index];
    1114                 :             : }
    1115                 :             : 
    1116                 :             : 
    1117                 :             : /* Create a character type with the given kind and length.  */
    1118                 :             : 
    1119                 :             : tree
    1120                 :       85250 : gfc_get_character_type_len_for_eltype (tree eltype, tree len)
    1121                 :             : {
    1122                 :       85250 :   tree bounds, type;
    1123                 :             : 
    1124                 :       85250 :   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
    1125                 :       85250 :   type = build_array_type (eltype, bounds);
    1126                 :       85250 :   TYPE_STRING_FLAG (type) = 1;
    1127                 :             : 
    1128                 :       85250 :   return type;
    1129                 :             : }
    1130                 :             : 
    1131                 :             : tree
    1132                 :       78033 : gfc_get_character_type_len (int kind, tree len)
    1133                 :             : {
    1134                 :       78033 :   gfc_validate_kind (BT_CHARACTER, kind, false);
    1135                 :       78033 :   return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
    1136                 :             : }
    1137                 :             : 
    1138                 :             : 
    1139                 :             : /* Get a type node for a character kind.  */
    1140                 :             : 
    1141                 :             : tree
    1142                 :       68264 : gfc_get_character_type (int kind, gfc_charlen * cl)
    1143                 :             : {
    1144                 :       68264 :   tree len;
    1145                 :             : 
    1146                 :       68264 :   len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
    1147                 :       67133 :   if (len && POINTER_TYPE_P (TREE_TYPE (len)))
    1148                 :           0 :     len = build_fold_indirect_ref (len);
    1149                 :             : 
    1150                 :       68264 :   return gfc_get_character_type_len (kind, len);
    1151                 :             : }
    1152                 :             : 
    1153                 :             : /* Convert a basic type.  This will be an array for character types.  */
    1154                 :             : 
    1155                 :             : tree
    1156                 :     1033814 : gfc_typenode_for_spec (gfc_typespec * spec, int codim)
    1157                 :             : {
    1158                 :     1033814 :   tree basetype;
    1159                 :             : 
    1160                 :     1033814 :   switch (spec->type)
    1161                 :             :     {
    1162                 :           0 :     case BT_UNKNOWN:
    1163                 :           0 :       gcc_unreachable ();
    1164                 :             : 
    1165                 :      388145 :     case BT_INTEGER:
    1166                 :             :       /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
    1167                 :             :          has been resolved.  This is done so we can convert C_PTR and
    1168                 :             :          C_FUNPTR to simple variables that get translated to (void *).  */
    1169                 :      388145 :       if (spec->f90_type == BT_VOID)
    1170                 :             :         {
    1171                 :         342 :           if (spec->u.derived
    1172                 :         342 :               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
    1173                 :         261 :             basetype = ptr_type_node;
    1174                 :             :           else
    1175                 :          81 :             basetype = pfunc_type_node;
    1176                 :             :         }
    1177                 :             :       else
    1178                 :      387803 :         basetype = gfc_get_int_type (spec->kind);
    1179                 :             :       break;
    1180                 :             : 
    1181                 :      125114 :     case BT_REAL:
    1182                 :      125114 :       basetype = gfc_get_real_type (spec->kind);
    1183                 :      125114 :       break;
    1184                 :             : 
    1185                 :       24860 :     case BT_COMPLEX:
    1186                 :       24860 :       basetype = gfc_get_complex_type (spec->kind);
    1187                 :       24860 :       break;
    1188                 :             : 
    1189                 :      301062 :     case BT_LOGICAL:
    1190                 :      301062 :       basetype = gfc_get_logical_type (spec->kind);
    1191                 :      301062 :       break;
    1192                 :             : 
    1193                 :       57231 :     case BT_CHARACTER:
    1194                 :       57231 :       basetype = gfc_get_character_type (spec->kind, spec->u.cl);
    1195                 :       57231 :       break;
    1196                 :             : 
    1197                 :          12 :     case BT_HOLLERITH:
    1198                 :             :       /* Since this cannot be used, return a length one character.  */
    1199                 :          12 :       basetype = gfc_get_character_type_len (gfc_default_character_kind,
    1200                 :             :                                              gfc_index_one_node);
    1201                 :          12 :       break;
    1202                 :             : 
    1203                 :         116 :     case BT_UNION:
    1204                 :         116 :       basetype = gfc_get_union_type (spec->u.derived);
    1205                 :         116 :       break;
    1206                 :             : 
    1207                 :      134490 :     case BT_DERIVED:
    1208                 :      134490 :     case BT_CLASS:
    1209                 :      134490 :       basetype = gfc_get_derived_type (spec->u.derived, codim);
    1210                 :             : 
    1211                 :      134490 :       if (spec->type == BT_CLASS)
    1212                 :       26974 :         GFC_CLASS_TYPE_P (basetype) = 1;
    1213                 :             : 
    1214                 :             :       /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
    1215                 :             :          type and kind to fit a (void *) and the basetype returned was a
    1216                 :             :          ptr_type_node.  We need to pass up this new information to the
    1217                 :             :          symbol that was declared of type C_PTR or C_FUNPTR.  */
    1218                 :      134490 :       if (spec->u.derived->ts.f90_type == BT_VOID)
    1219                 :             :         {
    1220                 :       10949 :           spec->type = BT_INTEGER;
    1221                 :       10949 :           spec->kind = gfc_index_integer_kind;
    1222                 :       10949 :           spec->f90_type = BT_VOID;
    1223                 :       10949 :           spec->is_c_interop = 1;  /* Mark as escaping later.  */
    1224                 :             :         }
    1225                 :             :       break;
    1226                 :        2764 :     case BT_VOID:
    1227                 :        2764 :     case BT_ASSUMED:
    1228                 :             :       /* This is for the second arg to c_f_pointer and c_f_procpointer
    1229                 :             :          of the iso_c_binding module, to accept any ptr type.  */
    1230                 :        2764 :       basetype = ptr_type_node;
    1231                 :        2764 :       if (spec->f90_type == BT_VOID)
    1232                 :             :         {
    1233                 :         338 :           if (spec->u.derived
    1234                 :           0 :               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
    1235                 :             :             basetype = ptr_type_node;
    1236                 :             :           else
    1237                 :         338 :             basetype = pfunc_type_node;
    1238                 :             :         }
    1239                 :             :        break;
    1240                 :          20 :     case BT_PROCEDURE:
    1241                 :          20 :       basetype = pfunc_type_node;
    1242                 :          20 :       break;
    1243                 :           0 :     default:
    1244                 :           0 :       gcc_unreachable ();
    1245                 :             :     }
    1246                 :     1033814 :   return basetype;
    1247                 :             : }
    1248                 :             : 
    1249                 :             : /* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
    1250                 :             : 
    1251                 :             : static tree
    1252                 :       86805 : gfc_conv_array_bound (gfc_expr * expr)
    1253                 :             : {
    1254                 :             :   /* If expr is an integer constant, return that.  */
    1255                 :       86805 :   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
    1256                 :       12167 :     return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
    1257                 :             : 
    1258                 :             :   /* Otherwise return NULL.  */
    1259                 :             :   return NULL_TREE;
    1260                 :             : }
    1261                 :             : 
    1262                 :             : /* Return the type of an element of the array.  Note that scalar coarrays
    1263                 :             :    are special.  In particular, for GFC_ARRAY_TYPE_P, the original argument
    1264                 :             :    (with POINTER_TYPE stripped) is returned.  */
    1265                 :             : 
    1266                 :             : tree
    1267                 :      279447 : gfc_get_element_type (tree type)
    1268                 :             : {
    1269                 :      279447 :   tree element;
    1270                 :             : 
    1271                 :      279447 :   if (GFC_ARRAY_TYPE_P (type))
    1272                 :             :     {
    1273                 :      108434 :       if (TREE_CODE (type) == POINTER_TYPE)
    1274                 :       19402 :         type = TREE_TYPE (type);
    1275                 :      108434 :       if (GFC_TYPE_ARRAY_RANK (type) == 0)
    1276                 :             :         {
    1277                 :         287 :           gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
    1278                 :             :           element = type;
    1279                 :             :         }
    1280                 :             :       else
    1281                 :             :         {
    1282                 :      108147 :           gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
    1283                 :      108147 :           element = TREE_TYPE (type);
    1284                 :             :         }
    1285                 :             :     }
    1286                 :             :   else
    1287                 :             :     {
    1288                 :      171013 :       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
    1289                 :      171013 :       element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
    1290                 :             : 
    1291                 :      171013 :       gcc_assert (TREE_CODE (element) == POINTER_TYPE);
    1292                 :      171013 :       element = TREE_TYPE (element);
    1293                 :             : 
    1294                 :             :       /* For arrays, which are not scalar coarrays.  */
    1295                 :      171013 :       if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
    1296                 :      169859 :         element = TREE_TYPE (element);
    1297                 :             :     }
    1298                 :             : 
    1299                 :      279447 :   return element;
    1300                 :             : }
    1301                 :             : 
    1302                 :             : /* Build an array.  This function is called from gfc_sym_type().
    1303                 :             :    Actually returns array descriptor type.
    1304                 :             : 
    1305                 :             :    Format of array descriptors is as follows:
    1306                 :             : 
    1307                 :             :     struct gfc_array_descriptor
    1308                 :             :     {
    1309                 :             :       array *data;
    1310                 :             :       index offset;
    1311                 :             :       struct dtype_type dtype;
    1312                 :             :       struct descriptor_dimension dimension[N_DIM];
    1313                 :             :     }
    1314                 :             : 
    1315                 :             :     struct dtype_type
    1316                 :             :     {
    1317                 :             :       size_t elem_len;
    1318                 :             :       int version;
    1319                 :             :       signed char rank;
    1320                 :             :       signed char type;
    1321                 :             :       signed short attribute;
    1322                 :             :     }
    1323                 :             : 
    1324                 :             :     struct descriptor_dimension
    1325                 :             :     {
    1326                 :             :       index stride;
    1327                 :             :       index lbound;
    1328                 :             :       index ubound;
    1329                 :             :     }
    1330                 :             : 
    1331                 :             :    Translation code should use gfc_conv_descriptor_* rather than
    1332                 :             :    accessing the descriptor directly.  Any changes to the array
    1333                 :             :    descriptor type will require changes in gfc_conv_descriptor_* and
    1334                 :             :    gfc_build_array_initializer.
    1335                 :             : 
    1336                 :             :    This is represented internally as a RECORD_TYPE. The index nodes
    1337                 :             :    are gfc_array_index_type and the data node is a pointer to the
    1338                 :             :    data.  See below for the handling of character types.
    1339                 :             : 
    1340                 :             :    I originally used nested ARRAY_TYPE nodes to represent arrays, but
    1341                 :             :    this generated poor code for assumed/deferred size arrays.  These
    1342                 :             :    require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
    1343                 :             :    of the GENERIC grammar.  Also, there is no way to explicitly set
    1344                 :             :    the array stride, so all data must be packed(1).  I've tried to
    1345                 :             :    mark all the functions which would require modification with a GCC
    1346                 :             :    ARRAYS comment.
    1347                 :             : 
    1348                 :             :    The data component points to the first element in the array.  The
    1349                 :             :    offset field is the position of the origin of the array (i.e. element
    1350                 :             :    (0, 0 ...)).  This may be outside the bounds of the array.
    1351                 :             : 
    1352                 :             :    An element is accessed by
    1353                 :             :     data[offset + index0*stride0 + index1*stride1 + index2*stride2]
    1354                 :             :    This gives good performance as the computation does not involve the
    1355                 :             :    bounds of the array.  For packed arrays, this is optimized further
    1356                 :             :    by substituting the known strides.
    1357                 :             : 
    1358                 :             :    This system has one problem: all array bounds must be within 2^31
    1359                 :             :    elements of the origin (2^63 on 64-bit machines).  For example
    1360                 :             :     integer, dimension (80000:90000, 80000:90000, 2) :: array
    1361                 :             :    may not work properly on 32-bit machines because 80000*80000 >
    1362                 :             :    2^31, so the calculation for stride2 would overflow.  This may
    1363                 :             :    still work, but I haven't checked, and it relies on the overflow
    1364                 :             :    doing the right thing.
    1365                 :             : 
    1366                 :             :    The way to fix this problem is to access elements as follows:
    1367                 :             :     data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
    1368                 :             :    Obviously this is much slower.  I will make this a compile time
    1369                 :             :    option, something like -fsmall-array-offsets.  Mixing code compiled
    1370                 :             :    with and without this switch will work.
    1371                 :             : 
    1372                 :             :    (1) This can be worked around by modifying the upper bound of the
    1373                 :             :    previous dimension.  This requires extra fields in the descriptor
    1374                 :             :    (both real_ubound and fake_ubound).  */
    1375                 :             : 
    1376                 :             : 
    1377                 :             : /* Returns true if the array sym does not require a descriptor.  */
    1378                 :             : 
    1379                 :             : bool
    1380                 :       92765 : gfc_is_nodesc_array (gfc_symbol * sym)
    1381                 :             : {
    1382                 :       92765 :   symbol_attribute *array_attr;
    1383                 :       92765 :   gfc_array_spec *as;
    1384                 :       92765 :   bool is_classarray = IS_CLASS_ARRAY (sym);
    1385                 :             : 
    1386                 :       92765 :   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
    1387                 :       92765 :   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
    1388                 :             : 
    1389                 :       92765 :   gcc_assert (array_attr->dimension || array_attr->codimension);
    1390                 :             : 
    1391                 :             :   /* We only want local arrays.  */
    1392                 :       92765 :   if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
    1393                 :       86279 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
    1394                 :       86279 :       || array_attr->allocatable)
    1395                 :             :     return 0;
    1396                 :             : 
    1397                 :             :   /* We want a descriptor for associate-name arrays that do not have an
    1398                 :             :          explicitly known shape already.  */
    1399                 :       78368 :   if (sym->assoc && as->type != AS_EXPLICIT)
    1400                 :             :     return 0;
    1401                 :             : 
    1402                 :             :   /* The dummy is stored in sym and not in the component.  */
    1403                 :       76754 :   if (sym->attr.dummy)
    1404                 :       34603 :     return as->type != AS_ASSUMED_SHAPE
    1405                 :       51639 :         && as->type != AS_ASSUMED_RANK;
    1406                 :             : 
    1407                 :       42151 :   if (sym->attr.result || sym->attr.function)
    1408                 :             :     return 0;
    1409                 :             : 
    1410                 :       34269 :   gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
    1411                 :             : 
    1412                 :             :   return 1;
    1413                 :             : }
    1414                 :             : 
    1415                 :             : 
    1416                 :             : /* Create an array descriptor type.  */
    1417                 :             : 
    1418                 :             : static tree
    1419                 :       41042 : gfc_build_array_type (tree type, gfc_array_spec * as,
    1420                 :             :                       enum gfc_array_kind akind, bool restricted,
    1421                 :             :                       bool contiguous, int codim)
    1422                 :             : {
    1423                 :       41042 :   tree lbound[GFC_MAX_DIMENSIONS];
    1424                 :       41042 :   tree ubound[GFC_MAX_DIMENSIONS];
    1425                 :       41042 :   int n, corank;
    1426                 :             : 
    1427                 :             :   /* Assumed-shape arrays do not have codimension information stored in the
    1428                 :             :      descriptor.  */
    1429                 :       41042 :   corank = MAX (as->corank, codim);
    1430                 :       41042 :   if (as->type == AS_ASSUMED_SHAPE ||
    1431                 :        6582 :       (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
    1432                 :       41042 :     corank = codim;
    1433                 :             : 
    1434                 :       41042 :   if (as->type == AS_ASSUMED_RANK)
    1435                 :      105312 :     for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
    1436                 :             :       {
    1437                 :       98730 :         lbound[n] = NULL_TREE;
    1438                 :       98730 :         ubound[n] = NULL_TREE;
    1439                 :             :       }
    1440                 :             : 
    1441                 :       89675 :   for (n = 0; n < as->rank; n++)
    1442                 :             :     {
    1443                 :             :       /* Create expressions for the known bounds of the array.  */
    1444                 :       48633 :       if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
    1445                 :       11432 :         lbound[n] = gfc_index_one_node;
    1446                 :             :       else
    1447                 :       37201 :         lbound[n] = gfc_conv_array_bound (as->lower[n]);
    1448                 :       48633 :       ubound[n] = gfc_conv_array_bound (as->upper[n]);
    1449                 :             :     }
    1450                 :             : 
    1451                 :       41870 :   for (n = as->rank; n < as->rank + corank; n++)
    1452                 :             :     {
    1453                 :         828 :       if (as->type != AS_DEFERRED && as->lower[n] == NULL)
    1454                 :           0 :         lbound[n] = gfc_index_one_node;
    1455                 :             :       else
    1456                 :         828 :         lbound[n] = gfc_conv_array_bound (as->lower[n]);
    1457                 :             : 
    1458                 :         828 :       if (n < as->rank + corank - 1)
    1459                 :         143 :         ubound[n] = gfc_conv_array_bound (as->upper[n]);
    1460                 :             :     }
    1461                 :             : 
    1462                 :       41042 :   if (as->type == AS_ASSUMED_SHAPE)
    1463                 :       13778 :     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
    1464                 :             :                        : GFC_ARRAY_ASSUMED_SHAPE;
    1465                 :       27264 :   else if (as->type == AS_ASSUMED_RANK)
    1466                 :        6582 :     akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
    1467                 :             :                        : GFC_ARRAY_ASSUMED_RANK;
    1468                 :       75502 :   return gfc_get_array_type_bounds (type, as->rank == -1
    1469                 :             :                                           ? GFC_MAX_DIMENSIONS : as->rank,
    1470                 :             :                                     corank, lbound, ubound, 0, akind,
    1471                 :       41042 :                                     restricted);
    1472                 :             : }
    1473                 :             : 
    1474                 :             : /* Returns the struct descriptor_dimension type.  */
    1475                 :             : 
    1476                 :             : static tree
    1477                 :       27693 : gfc_get_desc_dim_type (void)
    1478                 :             : {
    1479                 :       27693 :   tree type;
    1480                 :       27693 :   tree decl, *chain = NULL;
    1481                 :             : 
    1482                 :       27693 :   if (gfc_desc_dim_type)
    1483                 :             :     return gfc_desc_dim_type;
    1484                 :             : 
    1485                 :             :   /* Build the type node.  */
    1486                 :       10895 :   type = make_node (RECORD_TYPE);
    1487                 :             : 
    1488                 :       10895 :   TYPE_NAME (type) = get_identifier ("descriptor_dimension");
    1489                 :       10895 :   TYPE_PACKED (type) = 1;
    1490                 :             : 
    1491                 :             :   /* Consists of the stride, lbound and ubound members.  */
    1492                 :       10895 :   decl = gfc_add_field_to_struct_1 (type,
    1493                 :             :                                     get_identifier ("stride"),
    1494                 :             :                                     gfc_array_index_type, &chain);
    1495                 :       10895 :   suppress_warning (decl);
    1496                 :             : 
    1497                 :       10895 :   decl = gfc_add_field_to_struct_1 (type,
    1498                 :             :                                     get_identifier ("lbound"),
    1499                 :             :                                     gfc_array_index_type, &chain);
    1500                 :       10895 :   suppress_warning (decl);
    1501                 :             : 
    1502                 :       10895 :   decl = gfc_add_field_to_struct_1 (type,
    1503                 :             :                                     get_identifier ("ubound"),
    1504                 :             :                                     gfc_array_index_type, &chain);
    1505                 :       10895 :   suppress_warning (decl);
    1506                 :             : 
    1507                 :             :   /* Finish off the type.  */
    1508                 :       10895 :   gfc_finish_type (type);
    1509                 :       10895 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
    1510                 :             : 
    1511                 :       10895 :   gfc_desc_dim_type = type;
    1512                 :       10895 :   return type;
    1513                 :             : }
    1514                 :             : 
    1515                 :             : 
    1516                 :             : /* Return the DTYPE for an array.  This describes the type and type parameters
    1517                 :             :    of the array.  */
    1518                 :             : /* TODO: Only call this when the value is actually used, and make all the
    1519                 :             :    unknown cases abort.  */
    1520                 :             : 
    1521                 :             : tree
    1522                 :      119499 : gfc_get_dtype_rank_type (int rank, tree etype)
    1523                 :             : {
    1524                 :      119499 :   tree ptype;
    1525                 :      119499 :   tree size;
    1526                 :      119499 :   int n;
    1527                 :      119499 :   tree tmp;
    1528                 :      119499 :   tree dtype;
    1529                 :      119499 :   tree field;
    1530                 :      119499 :   vec<constructor_elt, va_gc> *v = NULL;
    1531                 :             : 
    1532                 :      119499 :   ptype = etype;
    1533                 :      119499 :   while (TREE_CODE (etype) == POINTER_TYPE
    1534                 :      146742 :          || TREE_CODE (etype) == ARRAY_TYPE)
    1535                 :             :     {
    1536                 :       27243 :       ptype = etype;
    1537                 :       27243 :       etype = TREE_TYPE (etype);
    1538                 :             :     }
    1539                 :             : 
    1540                 :      119499 :   gcc_assert (etype);
    1541                 :             : 
    1542                 :      119499 :   switch (TREE_CODE (etype))
    1543                 :             :     {
    1544                 :       70597 :     case INTEGER_TYPE:
    1545                 :       70597 :       if (TREE_CODE (ptype) == ARRAY_TYPE
    1546                 :       70597 :           && TYPE_STRING_FLAG (ptype))
    1547                 :             :         n = BT_CHARACTER;
    1548                 :             :       else
    1549                 :             :         n = BT_INTEGER;
    1550                 :             :       break;
    1551                 :             : 
    1552                 :             :     case BOOLEAN_TYPE:
    1553                 :             :       n = BT_LOGICAL;
    1554                 :             :       break;
    1555                 :             : 
    1556                 :             :     case REAL_TYPE:
    1557                 :             :       n = BT_REAL;
    1558                 :             :       break;
    1559                 :             : 
    1560                 :             :     case COMPLEX_TYPE:
    1561                 :             :       n = BT_COMPLEX;
    1562                 :             :       break;
    1563                 :             : 
    1564                 :       17316 :     case RECORD_TYPE:
    1565                 :       17316 :       if (GFC_CLASS_TYPE_P (etype))
    1566                 :             :         n = BT_CLASS;
    1567                 :             :       else
    1568                 :             :         n = BT_DERIVED;
    1569                 :             :       break;
    1570                 :             : 
    1571                 :        1671 :     case FUNCTION_TYPE:
    1572                 :        1671 :     case VOID_TYPE:
    1573                 :        1671 :       n = BT_VOID;
    1574                 :        1671 :       break;
    1575                 :             : 
    1576                 :           0 :     default:
    1577                 :             :       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
    1578                 :             :       /* We can encounter strange array types for temporary arrays.  */
    1579                 :           0 :       gcc_unreachable ();
    1580                 :             :     }
    1581                 :             : 
    1582                 :       23358 :   switch (n)
    1583                 :             :     {
    1584                 :       21687 :     case BT_CHARACTER:
    1585                 :       21687 :       gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE);
    1586                 :       21687 :       size = gfc_get_character_len_in_bytes (ptype);
    1587                 :       21687 :       break;
    1588                 :        1671 :     case BT_VOID:
    1589                 :        1671 :       gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
    1590                 :        1671 :       size = size_in_bytes (ptype);
    1591                 :        1671 :       break;
    1592                 :       96141 :     default:
    1593                 :       96141 :       size = size_in_bytes (etype);
    1594                 :       96141 :       break;
    1595                 :             :     }
    1596                 :             : 
    1597                 :      119499 :   gcc_assert (size);
    1598                 :             : 
    1599                 :      119499 :   STRIP_NOPS (size);
    1600                 :      119499 :   size = fold_convert (size_type_node, size);
    1601                 :      119499 :   tmp = get_dtype_type_node ();
    1602                 :      119499 :   field = gfc_advance_chain (TYPE_FIELDS (tmp),
    1603                 :             :                              GFC_DTYPE_ELEM_LEN);
    1604                 :      119499 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1605                 :             :                           fold_convert (TREE_TYPE (field), size));
    1606                 :      119499 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1607                 :             :                              GFC_DTYPE_VERSION);
    1608                 :      119499 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1609                 :             :                           build_zero_cst (TREE_TYPE (field)));
    1610                 :             : 
    1611                 :      119499 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1612                 :             :                              GFC_DTYPE_RANK);
    1613                 :      119499 :   if (rank >= 0)
    1614                 :      118912 :     CONSTRUCTOR_APPEND_ELT (v, field,
    1615                 :             :                             build_int_cst (TREE_TYPE (field), rank));
    1616                 :             : 
    1617                 :      119499 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1618                 :             :                              GFC_DTYPE_TYPE);
    1619                 :      119499 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1620                 :             :                           build_int_cst (TREE_TYPE (field), n));
    1621                 :             : 
    1622                 :      119499 :   dtype = build_constructor (tmp, v);
    1623                 :             : 
    1624                 :      119499 :   return dtype;
    1625                 :             : }
    1626                 :             : 
    1627                 :             : 
    1628                 :             : tree
    1629                 :       97212 : gfc_get_dtype (tree type, int * rank)
    1630                 :             : {
    1631                 :       97212 :   tree dtype;
    1632                 :       97212 :   tree etype;
    1633                 :       97212 :   int irnk;
    1634                 :             : 
    1635                 :       97212 :   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
    1636                 :             : 
    1637                 :       97212 :   irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type));
    1638                 :       97212 :   etype = gfc_get_element_type (type);
    1639                 :       97212 :   dtype = gfc_get_dtype_rank_type (irnk, etype);
    1640                 :             : 
    1641                 :       97212 :   GFC_TYPE_ARRAY_DTYPE (type) = dtype;
    1642                 :       97212 :   return dtype;
    1643                 :             : }
    1644                 :             : 
    1645                 :             : 
    1646                 :             : /* Build an array type for use without a descriptor, packed according
    1647                 :             :    to the value of PACKED.  */
    1648                 :             : 
    1649                 :             : tree
    1650                 :       92754 : gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
    1651                 :             :                            bool restricted)
    1652                 :             : {
    1653                 :       92754 :   tree range;
    1654                 :       92754 :   tree type;
    1655                 :       92754 :   tree tmp;
    1656                 :       92754 :   int n;
    1657                 :       92754 :   int known_stride;
    1658                 :       92754 :   int known_offset;
    1659                 :       92754 :   mpz_t offset;
    1660                 :       92754 :   mpz_t stride;
    1661                 :       92754 :   mpz_t delta;
    1662                 :       92754 :   gfc_expr *expr;
    1663                 :             : 
    1664                 :       92754 :   mpz_init_set_ui (offset, 0);
    1665                 :       92754 :   mpz_init_set_ui (stride, 1);
    1666                 :       92754 :   mpz_init (delta);
    1667                 :             : 
    1668                 :             :   /* We don't use build_array_type because this does not include
    1669                 :             :      lang-specific information (i.e. the bounds of the array) when checking
    1670                 :             :      for duplicates.  */
    1671                 :       92754 :   if (as->rank)
    1672                 :       92499 :     type = make_node (ARRAY_TYPE);
    1673                 :             :   else
    1674                 :         255 :     type = build_variant_type_copy (etype);
    1675                 :             : 
    1676                 :       92754 :   GFC_ARRAY_TYPE_P (type) = 1;
    1677                 :       92754 :   TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
    1678                 :             : 
    1679                 :       92754 :   known_stride = (packed != PACKED_NO);
    1680                 :       92754 :   known_offset = 1;
    1681                 :      201315 :   for (n = 0; n < as->rank; n++)
    1682                 :             :     {
    1683                 :             :       /* Fill in the stride and bound components of the type.  */
    1684                 :      108561 :       if (known_stride)
    1685                 :       96495 :         tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1686                 :             :       else
    1687                 :             :         tmp = NULL_TREE;
    1688                 :      108561 :       GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
    1689                 :             : 
    1690                 :      108561 :       expr = as->lower[n];
    1691                 :      108561 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1692                 :             :         {
    1693                 :      107769 :           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1694                 :             :                                       gfc_index_integer_kind);
    1695                 :             :         }
    1696                 :             :       else
    1697                 :             :         {
    1698                 :             :           known_stride = 0;
    1699                 :             :           tmp = NULL_TREE;
    1700                 :             :         }
    1701                 :      108561 :       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
    1702                 :             : 
    1703                 :      108561 :       if (known_stride)
    1704                 :             :         {
    1705                 :             :           /* Calculate the offset.  */
    1706                 :       96034 :           mpz_mul (delta, stride, as->lower[n]->value.integer);
    1707                 :       96034 :           mpz_sub (offset, offset, delta);
    1708                 :             :         }
    1709                 :             :       else
    1710                 :             :         known_offset = 0;
    1711                 :             : 
    1712                 :      108561 :       expr = as->upper[n];
    1713                 :      108561 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1714                 :             :         {
    1715                 :       84029 :           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1716                 :             :                                   gfc_index_integer_kind);
    1717                 :             :         }
    1718                 :             :       else
    1719                 :             :         {
    1720                 :             :           tmp = NULL_TREE;
    1721                 :             :           known_stride = 0;
    1722                 :             :         }
    1723                 :      108561 :       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    1724                 :             : 
    1725                 :      108561 :       if (known_stride)
    1726                 :             :         {
    1727                 :             :           /* Calculate the stride.  */
    1728                 :       83179 :           mpz_sub (delta, as->upper[n]->value.integer,
    1729                 :       83179 :                    as->lower[n]->value.integer);
    1730                 :       83179 :           mpz_add_ui (delta, delta, 1);
    1731                 :       83179 :           mpz_mul (stride, stride, delta);
    1732                 :             :         }
    1733                 :             : 
    1734                 :             :       /* Only the first stride is known for partial packed arrays.  */
    1735                 :      108561 :       if (packed == PACKED_NO || packed == PACKED_PARTIAL)
    1736                 :        9159 :         known_stride = 0;
    1737                 :             :     }
    1738                 :       93494 :   for (n = as->rank; n < as->rank + as->corank; n++)
    1739                 :             :     {
    1740                 :         740 :       expr = as->lower[n];
    1741                 :         740 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1742                 :         644 :         tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1743                 :             :                                     gfc_index_integer_kind);
    1744                 :             :       else
    1745                 :             :         tmp = NULL_TREE;
    1746                 :         740 :       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
    1747                 :             : 
    1748                 :         740 :       expr = as->upper[n];
    1749                 :         740 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1750                 :         142 :         tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1751                 :             :                                     gfc_index_integer_kind);
    1752                 :             :       else
    1753                 :             :         tmp = NULL_TREE;
    1754                 :         740 :       if (n < as->rank + as->corank - 1)
    1755                 :         192 :       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    1756                 :             :     }
    1757                 :             : 
    1758                 :       92754 :   if (known_offset)
    1759                 :             :     {
    1760                 :       83160 :       GFC_TYPE_ARRAY_OFFSET (type) =
    1761                 :       83160 :         gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
    1762                 :             :     }
    1763                 :             :   else
    1764                 :        9594 :     GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
    1765                 :             : 
    1766                 :       92754 :   if (known_stride)
    1767                 :             :     {
    1768                 :       66993 :       GFC_TYPE_ARRAY_SIZE (type) =
    1769                 :       66993 :         gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1770                 :             :     }
    1771                 :             :   else
    1772                 :       25761 :     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
    1773                 :             : 
    1774                 :       92754 :   GFC_TYPE_ARRAY_RANK (type) = as->rank;
    1775                 :       92754 :   GFC_TYPE_ARRAY_CORANK (type) = as->corank;
    1776                 :       92754 :   GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
    1777                 :       92754 :   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    1778                 :             :                             NULL_TREE);
    1779                 :             :   /* TODO: use main type if it is unbounded.  */
    1780                 :       92754 :   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    1781                 :       92754 :     build_pointer_type (build_array_type (etype, range));
    1782                 :       92754 :   if (restricted)
    1783                 :       89808 :     GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    1784                 :       89808 :       build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
    1785                 :             :                             TYPE_QUAL_RESTRICT);
    1786                 :             : 
    1787                 :       92754 :   if (as->rank == 0)
    1788                 :             :     {
    1789                 :         255 :       if (packed != PACKED_STATIC  || flag_coarray == GFC_FCOARRAY_LIB)
    1790                 :             :         {
    1791                 :         204 :           type = build_pointer_type (type);
    1792                 :             : 
    1793                 :         204 :           if (restricted)
    1794                 :         204 :             type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    1795                 :             : 
    1796                 :         204 :           GFC_ARRAY_TYPE_P (type) = 1;
    1797                 :         204 :           TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    1798                 :             :         }
    1799                 :             : 
    1800                 :         255 :       goto array_type_done;
    1801                 :             :     }
    1802                 :             : 
    1803                 :       92499 :   if (known_stride)
    1804                 :             :     {
    1805                 :       66738 :       mpz_sub_ui (stride, stride, 1);
    1806                 :       66738 :       range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1807                 :             :     }
    1808                 :             :   else
    1809                 :             :     range = NULL_TREE;
    1810                 :             : 
    1811                 :       92499 :   range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
    1812                 :       92499 :   TYPE_DOMAIN (type) = range;
    1813                 :             : 
    1814                 :       92499 :   build_pointer_type (etype);
    1815                 :       92499 :   TREE_TYPE (type) = etype;
    1816                 :             : 
    1817                 :       92499 :   layout_type (type);
    1818                 :             : 
    1819                 :             :   /* Represent packed arrays as multi-dimensional if they have rank >
    1820                 :             :      1 and with proper bounds, instead of flat arrays.  This makes for
    1821                 :             :      better debug info.  */
    1822                 :       92499 :   if (known_offset)
    1823                 :             :     {
    1824                 :       82905 :       tree gtype = etype, rtype, type_decl;
    1825                 :             : 
    1826                 :      176445 :       for (n = as->rank - 1; n >= 0; n--)
    1827                 :             :         {
    1828                 :      374160 :           rtype = build_range_type (gfc_array_index_type,
    1829                 :       93540 :                                     GFC_TYPE_ARRAY_LBOUND (type, n),
    1830                 :       93540 :                                     GFC_TYPE_ARRAY_UBOUND (type, n));
    1831                 :       93540 :           gtype = build_array_type (gtype, rtype);
    1832                 :             :         }
    1833                 :       82905 :       TYPE_NAME (type) = type_decl = build_decl (input_location,
    1834                 :             :                                                  TYPE_DECL, NULL, gtype);
    1835                 :       82905 :       DECL_ORIGINAL_TYPE (type_decl) = gtype;
    1836                 :             :     }
    1837                 :             : 
    1838                 :       92499 :   if (packed != PACKED_STATIC || !known_stride
    1839                 :       62962 :       || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
    1840                 :             :     {
    1841                 :             :       /* For dummy arrays and automatic (heap allocated) arrays we
    1842                 :             :          want a pointer to the array.  */
    1843                 :       29606 :       type = build_pointer_type (type);
    1844                 :       29606 :       if (restricted)
    1845                 :       28429 :         type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    1846                 :       29606 :       GFC_ARRAY_TYPE_P (type) = 1;
    1847                 :       29606 :       TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    1848                 :             :     }
    1849                 :             : 
    1850                 :       62893 : array_type_done:
    1851                 :       92754 :   mpz_clear (offset);
    1852                 :       92754 :   mpz_clear (stride);
    1853                 :       92754 :   mpz_clear (delta);
    1854                 :             : 
    1855                 :       92754 :   return type;
    1856                 :             : }
    1857                 :             : 
    1858                 :             : 
    1859                 :             : /* Return or create the base type for an array descriptor.  */
    1860                 :             : 
    1861                 :             : static tree
    1862                 :      251958 : gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
    1863                 :             : {
    1864                 :      251958 :   tree fat_type, decl, arraytype, *chain = NULL;
    1865                 :      251958 :   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
    1866                 :      251958 :   int idx;
    1867                 :             : 
    1868                 :             :   /* Assumed-rank array.  */
    1869                 :      251958 :   if (dimen == -1)
    1870                 :           0 :     dimen = GFC_MAX_DIMENSIONS;
    1871                 :             : 
    1872                 :      251958 :   idx = 2 * (codimen + dimen) + restricted;
    1873                 :             : 
    1874                 :      251958 :   gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
    1875                 :             : 
    1876                 :      251958 :   if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    1877                 :             :     {
    1878                 :        1010 :       if (gfc_array_descriptor_base_caf[idx])
    1879                 :             :         return gfc_array_descriptor_base_caf[idx];
    1880                 :             :     }
    1881                 :      250948 :   else if (gfc_array_descriptor_base[idx])
    1882                 :             :     return gfc_array_descriptor_base[idx];
    1883                 :             : 
    1884                 :             :   /* Build the type node.  */
    1885                 :       30301 :   fat_type = make_node (RECORD_TYPE);
    1886                 :             : 
    1887                 :       30301 :   sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
    1888                 :       30301 :   TYPE_NAME (fat_type) = get_identifier (name);
    1889                 :       30301 :   TYPE_NAMELESS (fat_type) = 1;
    1890                 :             : 
    1891                 :             :   /* Add the data member as the first element of the descriptor.  */
    1892                 :       30301 :   gfc_add_field_to_struct_1 (fat_type,
    1893                 :             :                              get_identifier ("data"),
    1894                 :             :                              (restricted
    1895                 :             :                               ? prvoid_type_node
    1896                 :             :                               : ptr_type_node), &chain);
    1897                 :             : 
    1898                 :             :   /* Add the base component.  */
    1899                 :       30301 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1900                 :             :                                     get_identifier ("offset"),
    1901                 :             :                                     gfc_array_index_type, &chain);
    1902                 :       30301 :   suppress_warning (decl);
    1903                 :             : 
    1904                 :             :   /* Add the dtype component.  */
    1905                 :       30301 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1906                 :             :                                     get_identifier ("dtype"),
    1907                 :             :                                     get_dtype_type_node (), &chain);
    1908                 :       30301 :   suppress_warning (decl);
    1909                 :             : 
    1910                 :             :   /* Add the span component.  */
    1911                 :       30301 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1912                 :             :                                     get_identifier ("span"),
    1913                 :             :                                     gfc_array_index_type, &chain);
    1914                 :       30301 :   suppress_warning (decl);
    1915                 :             : 
    1916                 :             :   /* Build the array type for the stride and bound components.  */
    1917                 :       30301 :   if (dimen + codimen > 0)
    1918                 :             :     {
    1919                 :       27693 :       arraytype =
    1920                 :       27693 :         build_array_type (gfc_get_desc_dim_type (),
    1921                 :             :                           build_range_type (gfc_array_index_type,
    1922                 :             :                                             gfc_index_zero_node,
    1923                 :       27693 :                                             gfc_rank_cst[codimen + dimen - 1]));
    1924                 :             : 
    1925                 :       27693 :       decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
    1926                 :             :                                         arraytype, &chain);
    1927                 :       27693 :       suppress_warning (decl);
    1928                 :             :     }
    1929                 :             : 
    1930                 :       30301 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    1931                 :             :     {
    1932                 :        1138 :       decl = gfc_add_field_to_struct_1 (fat_type,
    1933                 :             :                                         get_identifier ("token"),
    1934                 :             :                                         prvoid_type_node, &chain);
    1935                 :        1138 :       suppress_warning (decl);
    1936                 :             :     }
    1937                 :             : 
    1938                 :             :   /* Finish off the type.  */
    1939                 :       30301 :   gfc_finish_type (fat_type);
    1940                 :       30301 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
    1941                 :             : 
    1942                 :       30301 :   if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    1943                 :         420 :     gfc_array_descriptor_base_caf[idx] = fat_type;
    1944                 :             :   else
    1945                 :       29881 :     gfc_array_descriptor_base[idx] = fat_type;
    1946                 :             : 
    1947                 :             :   return fat_type;
    1948                 :             : }
    1949                 :             : 
    1950                 :             : 
    1951                 :             : /* Build an array (descriptor) type with given bounds.  */
    1952                 :             : 
    1953                 :             : tree
    1954                 :      125979 : gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
    1955                 :             :                            tree * ubound, int packed,
    1956                 :             :                            enum gfc_array_kind akind, bool restricted)
    1957                 :             : {
    1958                 :      125979 :   char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
    1959                 :      125979 :   tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
    1960                 :      125979 :   const char *type_name;
    1961                 :      125979 :   int n;
    1962                 :             : 
    1963                 :      125979 :   base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
    1964                 :      125979 :   fat_type = build_distinct_type_copy (base_type);
    1965                 :             :   /* Unshare TYPE_FIELDs.  */
    1966                 :      752592 :   for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp))
    1967                 :             :     {
    1968                 :      626613 :       tree next = DECL_CHAIN (*tp);
    1969                 :      626613 :       *tp = copy_node (*tp);
    1970                 :      626613 :       DECL_CONTEXT (*tp) = fat_type;
    1971                 :      626613 :       DECL_CHAIN (*tp) = next;
    1972                 :             :     }
    1973                 :             :   /* Make sure that nontarget and target array type have the same canonical
    1974                 :             :      type (and same stub decl for debug info).  */
    1975                 :      125979 :   base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
    1976                 :      125979 :   TYPE_CANONICAL (fat_type) = base_type;
    1977                 :      125979 :   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
    1978                 :             :   /* Arrays of unknown type must alias with all array descriptors.  */
    1979                 :      125979 :   TYPE_TYPELESS_STORAGE (base_type) = 1;
    1980                 :      125979 :   TYPE_TYPELESS_STORAGE (fat_type) = 1;
    1981                 :      125979 :   gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type));
    1982                 :             : 
    1983                 :      125979 :   tmp = etype;
    1984                 :      125979 :   if (TREE_CODE (tmp) == ARRAY_TYPE
    1985                 :      125979 :       && TYPE_STRING_FLAG (tmp))
    1986                 :       22227 :     tmp = TREE_TYPE (etype);
    1987                 :      125979 :   tmp = TYPE_NAME (tmp);
    1988                 :      125979 :   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
    1989                 :      105515 :     tmp = DECL_NAME (tmp);
    1990                 :      105515 :   if (tmp)
    1991                 :      123260 :     type_name = IDENTIFIER_POINTER (tmp);
    1992                 :             :   else
    1993                 :             :     type_name = "unknown";
    1994                 :      125979 :   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
    1995                 :             :            GFC_MAX_SYMBOL_LEN, type_name);
    1996                 :      125979 :   TYPE_NAME (fat_type) = get_identifier (name);
    1997                 :      125979 :   TYPE_NAMELESS (fat_type) = 1;
    1998                 :             : 
    1999                 :      125979 :   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
    2000                 :      125979 :   TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
    2001                 :             : 
    2002                 :      125979 :   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
    2003                 :      125979 :   GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
    2004                 :      125979 :   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
    2005                 :      125979 :   GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
    2006                 :             : 
    2007                 :             :   /* Build an array descriptor record type.  */
    2008                 :      125979 :   if (packed != 0)
    2009                 :       30845 :     stride = gfc_index_one_node;
    2010                 :             :   else
    2011                 :             :     stride = NULL_TREE;
    2012                 :      386926 :   for (n = 0; n < dimen + codimen; n++)
    2013                 :             :     {
    2014                 :      262028 :       if (n < dimen)
    2015                 :      260283 :         GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
    2016                 :             : 
    2017                 :      262028 :       if (lbound)
    2018                 :      262028 :         lower = lbound[n];
    2019                 :             :       else
    2020                 :             :         lower = NULL_TREE;
    2021                 :             : 
    2022                 :      262028 :       if (lower != NULL_TREE)
    2023                 :             :         {
    2024                 :      136430 :           if (INTEGER_CST_P (lower))
    2025                 :      135344 :             GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
    2026                 :             :           else
    2027                 :             :             lower = NULL_TREE;
    2028                 :             :         }
    2029                 :             : 
    2030                 :      262028 :       if (codimen && n == dimen + codimen - 1)
    2031                 :             :         break;
    2032                 :             : 
    2033                 :      260947 :       upper = ubound[n];
    2034                 :      260947 :       if (upper != NULL_TREE)
    2035                 :             :         {
    2036                 :      111679 :           if (INTEGER_CST_P (upper))
    2037                 :       86868 :             GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
    2038                 :             :           else
    2039                 :             :             upper = NULL_TREE;
    2040                 :             :         }
    2041                 :             : 
    2042                 :      260947 :       if (n >= dimen)
    2043                 :         664 :         continue;
    2044                 :             : 
    2045                 :      260283 :       if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
    2046                 :             :         {
    2047                 :       24371 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2048                 :             :                                  gfc_array_index_type, upper, lower);
    2049                 :       24371 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    2050                 :             :                                  gfc_array_index_type, tmp,
    2051                 :             :                                  gfc_index_one_node);
    2052                 :       24371 :           stride = fold_build2_loc (input_location, MULT_EXPR,
    2053                 :             :                                     gfc_array_index_type, tmp, stride);
    2054                 :             :           /* Check the folding worked.  */
    2055                 :       24371 :           gcc_assert (INTEGER_CST_P (stride));
    2056                 :             :         }
    2057                 :             :       else
    2058                 :             :         stride = NULL_TREE;
    2059                 :             :     }
    2060                 :      125979 :   GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
    2061                 :             : 
    2062                 :             :   /* TODO: known offsets for descriptors.  */
    2063                 :      125979 :   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
    2064                 :             : 
    2065                 :      125979 :   if (dimen == 0)
    2066                 :             :     {
    2067                 :        6206 :       arraytype =  build_pointer_type (etype);
    2068                 :        6206 :       if (restricted)
    2069                 :        5779 :         arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
    2070                 :             : 
    2071                 :        6206 :       GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
    2072                 :        6206 :       return fat_type;
    2073                 :             :     }
    2074                 :             : 
    2075                 :             :   /* We define data as an array with the correct size if possible.
    2076                 :             :      Much better than doing pointer arithmetic.  */
    2077                 :      119773 :   if (stride)
    2078                 :       19665 :     rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    2079                 :             :                               int_const_binop (MINUS_EXPR, stride,
    2080                 :       39330 :                                                build_int_cst (TREE_TYPE (stride), 1)));
    2081                 :             :   else
    2082                 :      100108 :     rtype = gfc_array_range_type;
    2083                 :      119773 :   arraytype = build_array_type (etype, rtype);
    2084                 :      119773 :   arraytype = build_pointer_type (arraytype);
    2085                 :      119773 :   if (restricted)
    2086                 :       55702 :     arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
    2087                 :      119773 :   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
    2088                 :             : 
    2089                 :             :   /* This will generate the base declarations we need to emit debug
    2090                 :             :      information for this type.  FIXME: there must be a better way to
    2091                 :             :      avoid divergence between compilations with and without debug
    2092                 :             :      information.  */
    2093                 :      119773 :   {
    2094                 :      119773 :     struct array_descr_info info;
    2095                 :      119773 :     gfc_get_array_descr_info (fat_type, &info);
    2096                 :      119773 :     gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
    2097                 :             :   }
    2098                 :             : 
    2099                 :      119773 :   return fat_type;
    2100                 :             : }
    2101                 :             : 
    2102                 :             : /* Build a pointer type. This function is called from gfc_sym_type().  */
    2103                 :             : 
    2104                 :             : static tree
    2105                 :       14418 : gfc_build_pointer_type (gfc_symbol * sym, tree type)
    2106                 :             : {
    2107                 :             :   /* Array pointer types aren't actually pointers.  */
    2108                 :           0 :   if (sym->attr.dimension)
    2109                 :             :     return type;
    2110                 :             :   else
    2111                 :       14418 :     return build_pointer_type (type);
    2112                 :             : }
    2113                 :             : 
    2114                 :             : static tree gfc_nonrestricted_type (tree t);
    2115                 :             : /* Given two record or union type nodes TO and FROM, ensure
    2116                 :             :    that all fields in FROM have a corresponding field in TO,
    2117                 :             :    their type being nonrestrict variants.  This accepts a TO
    2118                 :             :    node that already has a prefix of the fields in FROM.  */
    2119                 :             : static void
    2120                 :        2599 : mirror_fields (tree to, tree from)
    2121                 :             : {
    2122                 :        2599 :   tree fto, ffrom;
    2123                 :        2599 :   tree *chain;
    2124                 :             : 
    2125                 :             :   /* Forward to the end of TOs fields.  */
    2126                 :        2599 :   fto = TYPE_FIELDS (to);
    2127                 :        2599 :   ffrom = TYPE_FIELDS (from);
    2128                 :        2599 :   chain = &TYPE_FIELDS (to);
    2129                 :        2599 :   while (fto)
    2130                 :             :     {
    2131                 :           0 :       gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
    2132                 :           0 :       chain = &DECL_CHAIN (fto);
    2133                 :           0 :       fto = DECL_CHAIN (fto);
    2134                 :           0 :       ffrom = DECL_CHAIN (ffrom);
    2135                 :             :     }
    2136                 :             : 
    2137                 :             :   /* Now add all fields remaining in FROM (starting with ffrom).  */
    2138                 :       11330 :   for (; ffrom; ffrom = DECL_CHAIN (ffrom))
    2139                 :             :     {
    2140                 :        8731 :       tree newfield = copy_node (ffrom);
    2141                 :        8731 :       DECL_CONTEXT (newfield) = to;
    2142                 :             :       /* The store to DECL_CHAIN might seem redundant with the
    2143                 :             :          stores to *chain, but not clearing it here would mean
    2144                 :             :          leaving a chain into the old fields.  If ever
    2145                 :             :          our called functions would look at them confusion
    2146                 :             :          will arise.  */
    2147                 :        8731 :       DECL_CHAIN (newfield) = NULL_TREE;
    2148                 :        8731 :       *chain = newfield;
    2149                 :        8731 :       chain = &DECL_CHAIN (newfield);
    2150                 :             : 
    2151                 :        8731 :       if (TREE_CODE (ffrom) == FIELD_DECL)
    2152                 :             :         {
    2153                 :        8731 :           tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
    2154                 :        8731 :           TREE_TYPE (newfield) = elemtype;
    2155                 :             :         }
    2156                 :             :     }
    2157                 :        2599 :   *chain = NULL_TREE;
    2158                 :        2599 : }
    2159                 :             : 
    2160                 :             : /* Given a type T, returns a different type of the same structure,
    2161                 :             :    except that all types it refers to (recursively) are always
    2162                 :             :    non-restrict qualified types.  */
    2163                 :             : static tree
    2164                 :      230115 : gfc_nonrestricted_type (tree t)
    2165                 :             : {
    2166                 :      230115 :   tree ret = t;
    2167                 :             : 
    2168                 :             :   /* If the type isn't laid out yet, don't copy it.  If something
    2169                 :             :      needs it for real it should wait until the type got finished.  */
    2170                 :      230115 :   if (!TYPE_SIZE (t))
    2171                 :             :     return t;
    2172                 :             : 
    2173                 :      218980 :   if (!TYPE_LANG_SPECIFIC (t))
    2174                 :       90121 :     TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
    2175                 :             :   /* If we're dealing with this very node already further up
    2176                 :             :      the call chain (recursion via pointers and struct members)
    2177                 :             :      we haven't yet determined if we really need a new type node.
    2178                 :             :      Assume we don't, return T itself.  */
    2179                 :      218980 :   if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
    2180                 :             :     return t;
    2181                 :             : 
    2182                 :             :   /* If we have calculated this all already, just return it.  */
    2183                 :      211605 :   if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
    2184                 :      117922 :     return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
    2185                 :             : 
    2186                 :             :   /* Mark this type.  */
    2187                 :       93683 :   TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
    2188                 :             : 
    2189                 :       93683 :   switch (TREE_CODE (t))
    2190                 :             :     {
    2191                 :             :       default:
    2192                 :             :         break;
    2193                 :             : 
    2194                 :       36427 :       case POINTER_TYPE:
    2195                 :       36427 :       case REFERENCE_TYPE:
    2196                 :       36427 :         {
    2197                 :       36427 :           tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
    2198                 :       36427 :           if (totype == TREE_TYPE (t))
    2199                 :             :             ret = t;
    2200                 :        1080 :           else if (TREE_CODE (t) == POINTER_TYPE)
    2201                 :        1080 :             ret = build_pointer_type (totype);
    2202                 :             :           else
    2203                 :           0 :             ret = build_reference_type (totype);
    2204                 :       72854 :           ret = build_qualified_type (ret,
    2205                 :       36427 :                                       TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
    2206                 :             :         }
    2207                 :       36427 :         break;
    2208                 :             : 
    2209                 :        5335 :       case ARRAY_TYPE:
    2210                 :        5335 :         {
    2211                 :        5335 :           tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
    2212                 :        5335 :           if (elemtype == TREE_TYPE (t))
    2213                 :             :             ret = t;
    2214                 :             :           else
    2215                 :             :             {
    2216                 :          17 :               ret = build_variant_type_copy (t);
    2217                 :          17 :               TREE_TYPE (ret) = elemtype;
    2218                 :          17 :               if (TYPE_LANG_SPECIFIC (t)
    2219                 :          17 :                   && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
    2220                 :             :                 {
    2221                 :          17 :                   tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
    2222                 :          17 :                   dataptr_type = gfc_nonrestricted_type (dataptr_type);
    2223                 :          17 :                   if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
    2224                 :             :                     {
    2225                 :          17 :                       TYPE_LANG_SPECIFIC (ret)
    2226                 :          17 :                         = ggc_cleared_alloc<struct lang_type> ();
    2227                 :          17 :                       *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
    2228                 :          17 :                       GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
    2229                 :             :                     }
    2230                 :             :                 }
    2231                 :             :             }
    2232                 :             :         }
    2233                 :             :         break;
    2234                 :             : 
    2235                 :       25040 :       case RECORD_TYPE:
    2236                 :       25040 :       case UNION_TYPE:
    2237                 :       25040 :       case QUAL_UNION_TYPE:
    2238                 :       25040 :         {
    2239                 :       25040 :           tree field;
    2240                 :             :           /* First determine if we need a new type at all.
    2241                 :             :              Careful, the two calls to gfc_nonrestricted_type per field
    2242                 :             :              might return different values.  That happens exactly when
    2243                 :             :              one of the fields reaches back to this very record type
    2244                 :             :              (via pointers).  The first calls will assume that we don't
    2245                 :             :              need to copy T (see the error_mark_node marking).  If there
    2246                 :             :              are any reasons for copying T apart from having to copy T,
    2247                 :             :              we'll indeed copy it, and the second calls to
    2248                 :             :              gfc_nonrestricted_type will use that new node if they
    2249                 :             :              reach back to T.  */
    2250                 :      128007 :           for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
    2251                 :      105566 :             if (TREE_CODE (field) == FIELD_DECL)
    2252                 :             :               {
    2253                 :      105566 :                 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
    2254                 :      105566 :                 if (elemtype != TREE_TYPE (field))
    2255                 :             :                   break;
    2256                 :             :               }
    2257                 :       25040 :           if (!field)
    2258                 :             :             break;
    2259                 :        2599 :           ret = build_variant_type_copy (t);
    2260                 :        2599 :           TYPE_FIELDS (ret) = NULL_TREE;
    2261                 :             : 
    2262                 :             :           /* Here we make sure that as soon as we know we have to copy
    2263                 :             :              T, that also fields reaching back to us will use the new
    2264                 :             :              copy.  It's okay if that copy still contains the old fields,
    2265                 :             :              we won't look at them.  */
    2266                 :        2599 :           TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
    2267                 :        2599 :           mirror_fields (ret, t);
    2268                 :             :         }
    2269                 :        2599 :         break;
    2270                 :             :     }
    2271                 :             : 
    2272                 :       93683 :   TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
    2273                 :       93683 :   return ret;
    2274                 :             : }
    2275                 :             : 
    2276                 :             : 
    2277                 :             : /* Return the type for a symbol.  Special handling is required for character
    2278                 :             :    types to get the correct level of indirection.
    2279                 :             :    For functions return the return type.
    2280                 :             :    For subroutines return void_type_node.
    2281                 :             :    Calling this multiple times for the same symbol should be avoided,
    2282                 :             :    especially for character and array types.  */
    2283                 :             : 
    2284                 :             : tree
    2285                 :      358975 : gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
    2286                 :             : {
    2287                 :      358975 :   tree type;
    2288                 :      358975 :   int byref;
    2289                 :      358975 :   bool restricted;
    2290                 :             : 
    2291                 :             :   /* Procedure Pointers inside COMMON blocks.  */
    2292                 :      358975 :   if (sym->attr.proc_pointer && sym->attr.in_common)
    2293                 :             :     {
    2294                 :             :       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
    2295                 :          30 :       sym->attr.proc_pointer = 0;
    2296                 :          30 :       type = build_pointer_type (gfc_get_function_type (sym));
    2297                 :          30 :       sym->attr.proc_pointer = 1;
    2298                 :          30 :       return type;
    2299                 :             :     }
    2300                 :             : 
    2301                 :      358945 :   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
    2302                 :           0 :     return void_type_node;
    2303                 :             : 
    2304                 :             :   /* In the case of a function the fake result variable may have a
    2305                 :             :      type different from the function type, so don't return early in
    2306                 :             :      that case.  */
    2307                 :      358945 :   if (sym->backend_decl && !sym->attr.function)
    2308                 :         445 :     return TREE_TYPE (sym->backend_decl);
    2309                 :             : 
    2310                 :      358500 :   if (sym->attr.result
    2311                 :        5482 :       && sym->ts.type == BT_CHARACTER
    2312                 :        1083 :       && sym->ts.u.cl->backend_decl == NULL_TREE
    2313                 :         469 :       && sym->ns->proc_name
    2314                 :         463 :       && sym->ns->proc_name->ts.u.cl
    2315                 :         461 :       && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
    2316                 :           6 :     sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;
    2317                 :             : 
    2318                 :      358500 :   if (sym->ts.type == BT_CHARACTER
    2319                 :      358500 :       && ((sym->attr.function && sym->attr.is_bind_c)
    2320                 :       39118 :           || ((sym->attr.result || sym->attr.value)
    2321                 :        1499 :               && sym->ns->proc_name
    2322                 :        1493 :               && sym->ns->proc_name->attr.is_bind_c)
    2323                 :       38863 :           || (sym->ts.deferred && (!sym->ts.u.cl
    2324                 :        3294 :                                    || !sym->ts.u.cl->backend_decl))
    2325                 :       38015 :           || (sym->attr.dummy
    2326                 :       38015 :               && sym->attr.value
    2327                 :         163 :               && gfc_length_one_character_type_p (&sym->ts))))
    2328                 :        1294 :     type = gfc_get_char_type (sym->ts.kind);
    2329                 :             :   else
    2330                 :      357206 :     type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
    2331                 :             : 
    2332                 :      358500 :   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
    2333                 :      127349 :       && !sym->pass_as_value)
    2334                 :             :     byref = 1;
    2335                 :             :   else
    2336                 :      232127 :     byref = 0;
    2337                 :             : 
    2338                 :      331716 :   restricted = (!sym->attr.target && !IS_POINTER (sym)
    2339                 :      674572 :                 && !IS_PROC_POINTER (sym) && !sym->attr.cray_pointee);
    2340                 :       43103 :   if (!restricted)
    2341                 :       43103 :     type = gfc_nonrestricted_type (type);
    2342                 :             : 
    2343                 :             :   /* Dummy argument to a bind(C) procedure.  */
    2344                 :      358500 :   if (is_bind_c && is_CFI_desc (sym, NULL))
    2345                 :        3610 :     type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
    2346                 :             :                              /* restricted = */ false);
    2347                 :      354890 :   else if (sym->attr.dimension || sym->attr.codimension)
    2348                 :             :     {
    2349                 :       82848 :       if (gfc_is_nodesc_array (sym))
    2350                 :             :         {
    2351                 :             :           /* If this is a character argument of unknown length, just use the
    2352                 :             :              base type.  */
    2353                 :       46554 :           if (sym->ts.type != BT_CHARACTER
    2354                 :        5353 :               || !(sym->attr.dummy || sym->attr.function)
    2355                 :        1590 :               || sym->ts.u.cl->backend_decl)
    2356                 :             :             {
    2357                 :       46236 :               type = gfc_get_nodesc_array_type (type, sym->as,
    2358                 :             :                                                 byref ? PACKED_FULL
    2359                 :             :                                                       : PACKED_STATIC,
    2360                 :             :                                                 restricted);
    2361                 :       46236 :               byref = 0;
    2362                 :             :             }
    2363                 :             :         }
    2364                 :             :       else
    2365                 :             :         {
    2366                 :       36294 :           enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
    2367                 :       36294 :           if (sym->attr.pointer)
    2368                 :        6486 :             akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
    2369                 :             :                                          : GFC_ARRAY_POINTER;
    2370                 :       29808 :           else if (sym->attr.allocatable)
    2371                 :        7905 :             akind = GFC_ARRAY_ALLOCATABLE;
    2372                 :       36294 :           type = gfc_build_array_type (type, sym->as, akind, restricted,
    2373                 :       36294 :                                        sym->attr.contiguous, false);
    2374                 :             :         }
    2375                 :             :     }
    2376                 :             :   else
    2377                 :             :     {
    2378                 :      272042 :       if (sym->attr.allocatable || sym->attr.pointer
    2379                 :      272042 :           || gfc_is_associate_pointer (sym))
    2380                 :       14418 :         type = gfc_build_pointer_type (sym, type);
    2381                 :             :     }
    2382                 :             : 
    2383                 :             :   /* We currently pass all parameters by reference.
    2384                 :             :      See f95_get_function_decl.  For dummy function parameters return the
    2385                 :             :      function type.  */
    2386                 :      358500 :   if (byref)
    2387                 :             :     {
    2388                 :             :       /* We must use pointer types for potentially absent variables.  The
    2389                 :             :          optimizers assume a reference type argument is never NULL.  */
    2390                 :      114441 :       if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
    2391                 :      114441 :           || sym->attr.optional
    2392                 :      100972 :           || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
    2393                 :       15120 :         type = build_pointer_type (type);
    2394                 :             :       else
    2395                 :       99321 :         type = build_reference_type (type);
    2396                 :             : 
    2397                 :      114441 :       if (restricted)
    2398                 :      108019 :         type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    2399                 :             :     }
    2400                 :             : 
    2401                 :             :   return (type);
    2402                 :             : }
    2403                 :             : 
    2404                 :             : /* Layout and output debug info for a record type.  */
    2405                 :             : 
    2406                 :             : void
    2407                 :      314884 : gfc_finish_type (tree type)
    2408                 :             : {
    2409                 :      314884 :   tree decl;
    2410                 :             : 
    2411                 :      314884 :   decl = build_decl (input_location,
    2412                 :             :                      TYPE_DECL, NULL_TREE, type);
    2413                 :      314884 :   TYPE_STUB_DECL (type) = decl;
    2414                 :      314884 :   layout_type (type);
    2415                 :      314884 :   rest_of_type_compilation (type, 1);
    2416                 :      314884 :   rest_of_decl_compilation (decl, 1, 0);
    2417                 :      314884 : }
    2418                 :             : 
    2419                 :             : /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
    2420                 :             :    or RECORD_TYPE pointed to by CONTEXT.  The new field is chained
    2421                 :             :    to the end of the field list pointed to by *CHAIN.
    2422                 :             : 
    2423                 :             :    Returns a pointer to the new field.  */
    2424                 :             : 
    2425                 :             : static tree
    2426                 :     4716280 : gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
    2427                 :             : {
    2428                 :     4716280 :   tree decl = build_decl (input_location, FIELD_DECL, name, type);
    2429                 :             : 
    2430                 :     4716280 :   DECL_CONTEXT (decl) = context;
    2431                 :     4716280 :   DECL_CHAIN (decl) = NULL_TREE;
    2432                 :     4716280 :   if (TYPE_FIELDS (context) == NULL_TREE)
    2433                 :      309366 :     TYPE_FIELDS (context) = decl;
    2434                 :     4716280 :   if (chain != NULL)
    2435                 :             :     {
    2436                 :     4716280 :       if (*chain != NULL)
    2437                 :     4406914 :         **chain = decl;
    2438                 :     4716280 :       *chain = &DECL_CHAIN (decl);
    2439                 :             :     }
    2440                 :             : 
    2441                 :     4716280 :   return decl;
    2442                 :             : }
    2443                 :             : 
    2444                 :             : /* Like `gfc_add_field_to_struct_1', but adds alignment
    2445                 :             :    information.  */
    2446                 :             : 
    2447                 :             : tree
    2448                 :     4370243 : gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
    2449                 :             : {
    2450                 :     4370243 :   tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
    2451                 :             : 
    2452                 :     4370243 :   DECL_INITIAL (decl) = 0;
    2453                 :     4370243 :   SET_DECL_ALIGN (decl, 0);
    2454                 :     4370243 :   DECL_USER_ALIGN (decl) = 0;
    2455                 :             : 
    2456                 :     4370243 :   return decl;
    2457                 :             : }
    2458                 :             : 
    2459                 :             : 
    2460                 :             : /* Copy the backend_decl and component backend_decls if
    2461                 :             :    the two derived type symbols are "equal", as described
    2462                 :             :    in 4.4.2 and resolved by gfc_compare_derived_types.  */
    2463                 :             : 
    2464                 :             : bool
    2465                 :      306232 : gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
    2466                 :             :                            bool from_gsym)
    2467                 :             : {
    2468                 :      306232 :   gfc_component *to_cm;
    2469                 :      306232 :   gfc_component *from_cm;
    2470                 :             : 
    2471                 :      306232 :   if (from == to)
    2472                 :             :     return 1;
    2473                 :             : 
    2474                 :      267209 :   if (from->backend_decl == NULL
    2475                 :      267209 :         || !gfc_compare_derived_types (from, to))
    2476                 :      254124 :     return 0;
    2477                 :             : 
    2478                 :       13085 :   to->backend_decl = from->backend_decl;
    2479                 :             : 
    2480                 :       13085 :   to_cm = to->components;
    2481                 :       13085 :   from_cm = from->components;
    2482                 :             : 
    2483                 :             :   /* Copy the component declarations.  If a component is itself
    2484                 :             :      a derived type, we need a copy of its component declarations.
    2485                 :             :      This is done by recursing into gfc_get_derived_type and
    2486                 :             :      ensures that the component's component declarations have
    2487                 :             :      been built.  If it is a character, we need the character
    2488                 :             :      length, as well.  */
    2489                 :       49254 :   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
    2490                 :             :     {
    2491                 :       36169 :       to_cm->backend_decl = from_cm->backend_decl;
    2492                 :       36169 :       to_cm->caf_token = from_cm->caf_token;
    2493                 :       36169 :       if (from_cm->ts.type == BT_UNION)
    2494                 :          28 :         gfc_get_union_type (to_cm->ts.u.derived);
    2495                 :       36141 :       else if (from_cm->ts.type == BT_DERIVED
    2496                 :       12331 :           && (!from_cm->attr.pointer || from_gsym))
    2497                 :       11259 :         gfc_get_derived_type (to_cm->ts.u.derived);
    2498                 :       24882 :       else if (from_cm->ts.type == BT_CLASS
    2499                 :         692 :                && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
    2500                 :         685 :         gfc_get_derived_type (to_cm->ts.u.derived);
    2501                 :       24197 :       else if (from_cm->ts.type == BT_CHARACTER)
    2502                 :         786 :         to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
    2503                 :             :     }
    2504                 :             : 
    2505                 :             :   return 1;
    2506                 :             : }
    2507                 :             : 
    2508                 :             : 
    2509                 :             : /* Build a tree node for a procedure pointer component.  */
    2510                 :             : 
    2511                 :             : static tree
    2512                 :       30566 : gfc_get_ppc_type (gfc_component* c)
    2513                 :             : {
    2514                 :       30566 :   tree t;
    2515                 :             : 
    2516                 :             :   /* Explicit interface.  */
    2517                 :       30566 :   if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
    2518                 :        3107 :     return build_pointer_type (gfc_get_function_type (c->ts.interface));
    2519                 :             : 
    2520                 :             :   /* Implicit interface (only return value may be known).  */
    2521                 :       27459 :   if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
    2522                 :           3 :     t = gfc_typenode_for_spec (&c->ts);
    2523                 :             :   else
    2524                 :       27456 :     t = void_type_node;
    2525                 :             : 
    2526                 :             :   /* FIXME: it would be better to provide explicit interfaces in all
    2527                 :             :      cases, since they should be known by the compiler.  */
    2528                 :       27459 :   return build_pointer_type (build_function_type (t, NULL_TREE));
    2529                 :             : }
    2530                 :             : 
    2531                 :             : 
    2532                 :             : /* Build a tree node for a union type. Requires building each map
    2533                 :             :    structure which is an element of the union. */
    2534                 :             : 
    2535                 :             : tree
    2536                 :         252 : gfc_get_union_type (gfc_symbol *un)
    2537                 :             : {
    2538                 :         252 :     gfc_component *map = NULL;
    2539                 :         252 :     tree typenode = NULL, map_type = NULL, map_field = NULL;
    2540                 :         252 :     tree *chain = NULL;
    2541                 :             : 
    2542                 :         252 :     if (un->backend_decl)
    2543                 :             :       {
    2544                 :         130 :         if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
    2545                 :             :           return un->backend_decl;
    2546                 :             :         else
    2547                 :             :           typenode = un->backend_decl;
    2548                 :             :       }
    2549                 :             :     else
    2550                 :             :       {
    2551                 :         122 :         typenode = make_node (UNION_TYPE);
    2552                 :         122 :         TYPE_NAME (typenode) = get_identifier (un->name);
    2553                 :             :       }
    2554                 :             : 
    2555                 :             :     /* Add each contained MAP as a field. */
    2556                 :         363 :     for (map = un->components; map; map = map->next)
    2557                 :             :       {
    2558                 :         238 :         gcc_assert (map->ts.type == BT_DERIVED);
    2559                 :             : 
    2560                 :             :         /* The map's type node, which is defined within this union's context. */
    2561                 :         238 :         map_type = gfc_get_derived_type (map->ts.u.derived);
    2562                 :         238 :         TYPE_CONTEXT (map_type) = typenode;
    2563                 :             : 
    2564                 :             :         /* The map field's declaration. */
    2565                 :         238 :         map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
    2566                 :             :                                             map_type, &chain);
    2567                 :         238 :         if (map->loc.lb)
    2568                 :         238 :           gfc_set_decl_location (map_field, &map->loc);
    2569                 :           0 :         else if (un->declared_at.lb)
    2570                 :           0 :           gfc_set_decl_location (map_field, &un->declared_at);
    2571                 :             : 
    2572                 :         238 :         DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
    2573                 :         238 :         DECL_NAMELESS(map_field) = true;
    2574                 :             : 
    2575                 :             :         /* We should never clobber another backend declaration for this map,
    2576                 :             :            because each map component is unique. */
    2577                 :         238 :         if (!map->backend_decl)
    2578                 :         238 :           map->backend_decl = map_field;
    2579                 :             :       }
    2580                 :             : 
    2581                 :         125 :     un->backend_decl = typenode;
    2582                 :         125 :     gfc_finish_type (typenode);
    2583                 :             : 
    2584                 :         125 :     return typenode;
    2585                 :             : }
    2586                 :             : 
    2587                 :             : 
    2588                 :             : /* Build a tree node for a derived type.  If there are equal
    2589                 :             :    derived types, with different local names, these are built
    2590                 :             :    at the same time.  If an equal derived type has been built
    2591                 :             :    in a parent namespace, this is used.  */
    2592                 :             : 
    2593                 :             : tree
    2594                 :      166665 : gfc_get_derived_type (gfc_symbol * derived, int codimen)
    2595                 :             : {
    2596                 :      166665 :   tree typenode = NULL, field = NULL, field_type = NULL;
    2597                 :      166665 :   tree canonical = NULL_TREE;
    2598                 :      166665 :   tree *chain = NULL;
    2599                 :      166665 :   bool got_canonical = false;
    2600                 :      166665 :   bool unlimited_entity = false;
    2601                 :      166665 :   gfc_component *c;
    2602                 :      166665 :   gfc_namespace *ns;
    2603                 :      166665 :   tree tmp;
    2604                 :      166665 :   bool coarray_flag;
    2605                 :             : 
    2606                 :      333330 :   coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
    2607                 :      166665 :                  && derived->module && !derived->attr.vtype;
    2608                 :             : 
    2609                 :      166665 :   gcc_assert (!derived->attr.pdt_template);
    2610                 :             : 
    2611                 :      166665 :   if (derived->attr.unlimited_polymorphic
    2612                 :      164390 :       || (flag_coarray == GFC_FCOARRAY_LIB
    2613                 :        1984 :           && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2614                 :          36 :           && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
    2615                 :             :               || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
    2616                 :          36 :               || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
    2617                 :        2311 :     return ptr_type_node;
    2618                 :             : 
    2619                 :      164354 :   if (flag_coarray != GFC_FCOARRAY_LIB
    2620                 :      162406 :       && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2621                 :         410 :       && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
    2622                 :         410 :           || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
    2623                 :         298 :     return gfc_get_int_type (gfc_default_integer_kind);
    2624                 :             : 
    2625                 :      164056 :   if (derived && derived->attr.flavor == FL_PROCEDURE
    2626                 :          52 :       && derived->attr.generic)
    2627                 :          52 :     derived = gfc_find_dt_in_generic (derived);
    2628                 :             : 
    2629                 :             :   /* See if it's one of the iso_c_binding derived types.  */
    2630                 :      164056 :   if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
    2631                 :             :     {
    2632                 :       12388 :       if (derived->backend_decl)
    2633                 :             :         return derived->backend_decl;
    2634                 :             : 
    2635                 :        4952 :       if (derived->intmod_sym_id == ISOCBINDING_PTR)
    2636                 :        2648 :         derived->backend_decl = ptr_type_node;
    2637                 :             :       else
    2638                 :        2304 :         derived->backend_decl = pfunc_type_node;
    2639                 :             : 
    2640                 :        4952 :       derived->ts.kind = gfc_index_integer_kind;
    2641                 :        4952 :       derived->ts.type = BT_INTEGER;
    2642                 :             :       /* Set the f90_type to BT_VOID as a way to recognize something of type
    2643                 :             :          BT_INTEGER that needs to fit a void * for the purpose of the
    2644                 :             :          iso_c_binding derived types.  */
    2645                 :        4952 :       derived->ts.f90_type = BT_VOID;
    2646                 :             : 
    2647                 :        4952 :       return derived->backend_decl;
    2648                 :             :     }
    2649                 :             : 
    2650                 :             :   /* If use associated, use the module type for this one.  */
    2651                 :      151668 :   if (derived->backend_decl == NULL
    2652                 :       36677 :       && (derived->attr.use_assoc || derived->attr.used_in_submodule)
    2653                 :        9819 :       && derived->module
    2654                 :      161487 :       && gfc_get_module_backend_decl (derived))
    2655                 :        9472 :     goto copy_derived_types;
    2656                 :             : 
    2657                 :             :   /* The derived types from an earlier namespace can be used as the
    2658                 :             :      canonical type.  */
    2659                 :      142196 :   if (derived->backend_decl == NULL
    2660                 :             :       && !derived->attr.use_assoc
    2661                 :       27205 :       && !derived->attr.used_in_submodule
    2662                 :       26858 :       && gfc_global_ns_list)
    2663                 :             :     {
    2664                 :        7313 :       for (ns = gfc_global_ns_list;
    2665                 :       34150 :            ns->translated && !got_canonical;
    2666                 :        7313 :            ns = ns->sibling)
    2667                 :             :         {
    2668                 :        7313 :           if (ns->derived_types)
    2669                 :             :             {
    2670                 :       26539 :               for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical;
    2671                 :             :                    dt = dt->dt_next)
    2672                 :             :                 {
    2673                 :       26321 :                   gfc_copy_dt_decls_ifequal (dt, derived, true);
    2674                 :       26321 :                   if (derived->backend_decl)
    2675                 :         357 :                     got_canonical = true;
    2676                 :       26321 :                   if (dt->dt_next == ns->derived_types)
    2677                 :             :                     break;
    2678                 :             :                 }
    2679                 :             :             }
    2680                 :             :         }
    2681                 :             :     }
    2682                 :             : 
    2683                 :             :   /* Store up the canonical type to be added to this one.  */
    2684                 :       26837 :   if (got_canonical)
    2685                 :             :     {
    2686                 :         357 :       if (TYPE_CANONICAL (derived->backend_decl))
    2687                 :         357 :         canonical = TYPE_CANONICAL (derived->backend_decl);
    2688                 :             :       else
    2689                 :             :         canonical = derived->backend_decl;
    2690                 :             : 
    2691                 :         357 :       derived->backend_decl = NULL_TREE;
    2692                 :             :     }
    2693                 :             : 
    2694                 :             :   /* derived->backend_decl != 0 means we saw it before, but its
    2695                 :             :      components' backend_decl may have not been built.  */
    2696                 :      142196 :   if (derived->backend_decl)
    2697                 :             :     {
    2698                 :             :       /* Its components' backend_decl have been built or we are
    2699                 :             :          seeing recursion through the formal arglist of a procedure
    2700                 :             :          pointer component.  */
    2701                 :      114991 :       if (TYPE_FIELDS (derived->backend_decl))
    2702                 :             :         return derived->backend_decl;
    2703                 :        4707 :       else if (derived->attr.abstract
    2704                 :        4707 :                && derived->attr.proc_pointer_comp)
    2705                 :             :         {
    2706                 :             :           /* If an abstract derived type with procedure pointer
    2707                 :             :              components has no other type of component, return the
    2708                 :             :              backend_decl. Otherwise build the components if any of the
    2709                 :             :              non-procedure pointer components have no backend_decl.  */
    2710                 :          13 :           for (c = derived->components; c; c = c->next)
    2711                 :             :             {
    2712                 :          26 :               bool same_alloc_type = c->attr.allocatable
    2713                 :          13 :                                      && derived == c->ts.u.derived;
    2714                 :          13 :               if (!c->attr.proc_pointer
    2715                 :           1 :                   && !same_alloc_type
    2716                 :           1 :                   && c->backend_decl == NULL)
    2717                 :             :                 break;
    2718                 :          12 :               else if (c->next == NULL)
    2719                 :             :                 return derived->backend_decl;
    2720                 :             :             }
    2721                 :             :           typenode = derived->backend_decl;
    2722                 :             :         }
    2723                 :             :       else
    2724                 :             :         typenode = derived->backend_decl;
    2725                 :             :     }
    2726                 :             :   else
    2727                 :             :     {
    2728                 :             :       /* We see this derived type first time, so build the type node.  */
    2729                 :       27205 :       typenode = make_node (RECORD_TYPE);
    2730                 :       27205 :       TYPE_NAME (typenode) = get_identifier (derived->name);
    2731                 :       27205 :       TYPE_PACKED (typenode) = flag_pack_derived;
    2732                 :       27205 :       derived->backend_decl = typenode;
    2733                 :             :     }
    2734                 :             : 
    2735                 :       31906 :   if (derived->components
    2736                 :       26393 :         && derived->components->ts.type == BT_DERIVED
    2737                 :        9154 :         && strcmp (derived->components->name, "_data") == 0
    2738                 :        6636 :         && derived->components->ts.u.derived->attr.unlimited_polymorphic)
    2739                 :       31906 :     unlimited_entity = true;
    2740                 :             : 
    2741                 :             :   /* Go through the derived type components, building them as
    2742                 :             :      necessary. The reason for doing this now is that it is
    2743                 :             :      possible to recurse back to this derived type through a
    2744                 :             :      pointer component (PR24092). If this happens, the fields
    2745                 :             :      will be built and so we can return the type.  */
    2746                 :      131941 :   for (c = derived->components; c; c = c->next)
    2747                 :             :     {
    2748                 :      200070 :       bool same_alloc_type = c->attr.allocatable
    2749                 :      100035 :                              && derived == c->ts.u.derived;
    2750                 :             : 
    2751                 :      100035 :       if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
    2752                 :         108 :         c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);
    2753                 :             : 
    2754                 :      100035 :       if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
    2755                 :       64960 :         continue;
    2756                 :             : 
    2757                 :       35075 :       if ((!c->attr.pointer && !c->attr.proc_pointer
    2758                 :        5861 :           && !same_alloc_type)
    2759                 :       29259 :           || c->ts.u.derived->backend_decl == NULL)
    2760                 :             :         {
    2761                 :        8626 :           int local_codim = c->attr.codimension ? c->as->corank: codimen;
    2762                 :        8626 :           c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
    2763                 :             :                                                                 local_codim);
    2764                 :             :         }
    2765                 :             : 
    2766                 :       35075 :       if (c->ts.u.derived->attr.is_iso_c)
    2767                 :             :         {
    2768                 :             :           /* Need to copy the modified ts from the derived type.  The
    2769                 :             :              typespec was modified because C_PTR/C_FUNPTR are translated
    2770                 :             :              into (void *) from derived types.  */
    2771                 :          22 :           c->ts.type = c->ts.u.derived->ts.type;
    2772                 :          22 :           c->ts.kind = c->ts.u.derived->ts.kind;
    2773                 :          22 :           c->ts.f90_type = c->ts.u.derived->ts.f90_type;
    2774                 :          22 :           if (c->initializer)
    2775                 :             :             {
    2776                 :          21 :               c->initializer->ts.type = c->ts.type;
    2777                 :          21 :               c->initializer->ts.kind = c->ts.kind;
    2778                 :          21 :               c->initializer->ts.f90_type = c->ts.f90_type;
    2779                 :          21 :               c->initializer->expr_type = EXPR_NULL;
    2780                 :             :             }
    2781                 :             :         }
    2782                 :             :     }
    2783                 :             : 
    2784                 :       31906 :   if (TYPE_FIELDS (derived->backend_decl))
    2785                 :             :     return derived->backend_decl;
    2786                 :             : 
    2787                 :             :   /* Build the type member list. Install the newly created RECORD_TYPE
    2788                 :             :      node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
    2789                 :             :      through only the top-level linked list of components so we correctly
    2790                 :             :      build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
    2791                 :             :      types are built as part of gfc_get_union_type.  */
    2792                 :      131735 :   for (c = derived->components; c; c = c->next)
    2793                 :             :     {
    2794                 :      199806 :       bool same_alloc_type = c->attr.allocatable
    2795                 :       99903 :                              && derived == c->ts.u.derived;
    2796                 :             :       /* Prevent infinite recursion, when the procedure pointer type is
    2797                 :             :          the same as derived, by forcing the procedure pointer component to
    2798                 :             :          be built as if the explicit interface does not exist.  */
    2799                 :       99903 :       if (c->attr.proc_pointer
    2800                 :       30604 :           && (c->ts.type != BT_DERIVED || (c->ts.u.derived
    2801                 :         163 :                     && !gfc_compare_derived_types (derived, c->ts.u.derived)))
    2802                 :      130483 :           && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
    2803                 :         325 :                     && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
    2804                 :       30566 :         field_type = gfc_get_ppc_type (c);
    2805                 :       69337 :       else if (c->attr.proc_pointer && derived->backend_decl)
    2806                 :             :         {
    2807                 :          38 :           tmp = build_function_type (derived->backend_decl, NULL_TREE);
    2808                 :          38 :           field_type = build_pointer_type (tmp);
    2809                 :             :         }
    2810                 :       69299 :       else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
    2811                 :       34447 :         field_type = c->ts.u.derived->backend_decl;
    2812                 :       34852 :       else if (c->attr.caf_token)
    2813                 :         101 :         field_type = pvoid_type_node;
    2814                 :             :       else
    2815                 :             :         {
    2816                 :       34751 :           if (c->ts.type == BT_CHARACTER
    2817                 :        1774 :               && !c->ts.deferred && !c->attr.pdt_string)
    2818                 :             :             {
    2819                 :             :               /* Evaluate the string length.  */
    2820                 :        1361 :               gfc_conv_const_charlen (c->ts.u.cl);
    2821                 :        1361 :               gcc_assert (c->ts.u.cl->backend_decl);
    2822                 :             :             }
    2823                 :       33390 :           else if (c->ts.type == BT_CHARACTER)
    2824                 :         413 :             c->ts.u.cl->backend_decl
    2825                 :         413 :                         = build_int_cst (gfc_charlen_type_node, 0);
    2826                 :             : 
    2827                 :       34751 :           field_type = gfc_typenode_for_spec (&c->ts, codimen);
    2828                 :             :         }
    2829                 :             : 
    2830                 :             :       /* This returns an array descriptor type.  Initialization may be
    2831                 :             :          required.  */
    2832                 :       99903 :       if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
    2833                 :             :         {
    2834                 :        6063 :           if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
    2835                 :             :             {
    2836                 :        4748 :               enum gfc_array_kind akind;
    2837                 :        4748 :               if (c->attr.pointer)
    2838                 :        1906 :                 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
    2839                 :             :                                            : GFC_ARRAY_POINTER;
    2840                 :             :               else
    2841                 :             :                 akind = GFC_ARRAY_ALLOCATABLE;
    2842                 :             :               /* Pointers to arrays aren't actually pointer types.  The
    2843                 :             :                  descriptors are separate, but the data is common.  */
    2844                 :        4748 :               field_type = gfc_build_array_type (field_type, c->as, akind,
    2845                 :             :                                                  !c->attr.target
    2846                 :             :                                                  && !c->attr.pointer,
    2847                 :             :                                                  c->attr.contiguous,
    2848                 :             :                                                  codimen);
    2849                 :        4748 :             }
    2850                 :             :           else
    2851                 :        1315 :             field_type = gfc_get_nodesc_array_type (field_type, c->as,
    2852                 :             :                                                     PACKED_STATIC,
    2853                 :             :                                                     !c->attr.target);
    2854                 :             :         }
    2855                 :       93840 :       else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
    2856                 :       31024 :                && !c->attr.proc_pointer
    2857                 :       30874 :                && !(unlimited_entity && c == derived->components))
    2858                 :       30386 :         field_type = build_pointer_type (field_type);
    2859                 :             : 
    2860                 :       99903 :       if (c->attr.pointer || same_alloc_type)
    2861                 :       30936 :         field_type = gfc_nonrestricted_type (field_type);
    2862                 :             : 
    2863                 :             :       /* vtype fields can point to different types to the base type.  */
    2864                 :       99903 :       if (c->ts.type == BT_DERIVED
    2865                 :       33913 :             && c->ts.u.derived && c->ts.u.derived->attr.vtype)
    2866                 :       15226 :           field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
    2867                 :             :                                                     ptr_mode, true);
    2868                 :             : 
    2869                 :             :       /* Ensure that the CLASS language specific flag is set.  */
    2870                 :       99903 :       if (c->ts.type == BT_CLASS)
    2871                 :             :         {
    2872                 :        1022 :           if (POINTER_TYPE_P (field_type))
    2873                 :         325 :             GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
    2874                 :             :           else
    2875                 :         697 :             GFC_CLASS_TYPE_P (field_type) = 1;
    2876                 :             :         }
    2877                 :             : 
    2878                 :       99903 :       field = gfc_add_field_to_struct (typenode,
    2879                 :             :                                        get_identifier (c->name),
    2880                 :             :                                        field_type, &chain);
    2881                 :       99903 :       if (c->loc.lb)
    2882                 :       99903 :         gfc_set_decl_location (field, &c->loc);
    2883                 :           0 :       else if (derived->declared_at.lb)
    2884                 :           0 :         gfc_set_decl_location (field, &derived->declared_at);
    2885                 :             : 
    2886                 :       99903 :       gfc_finish_decl_attrs (field, &c->attr);
    2887                 :             : 
    2888                 :       99903 :       DECL_PACKED (field) |= TYPE_PACKED (typenode);
    2889                 :             : 
    2890                 :       99903 :       gcc_assert (field);
    2891                 :       99903 :       if (!c->backend_decl)
    2892                 :       98626 :         c->backend_decl = field;
    2893                 :             : 
    2894                 :       99903 :       if (c->attr.pointer && c->attr.dimension
    2895                 :        1890 :           && !(c->ts.type == BT_DERIVED
    2896                 :        1466 :                && strcmp (c->name, "_data") == 0))
    2897                 :         554 :         GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
    2898                 :             :     }
    2899                 :             : 
    2900                 :             :   /* Now lay out the derived type, including the fields.  */
    2901                 :       31832 :   if (canonical)
    2902                 :         357 :     TYPE_CANONICAL (typenode) = canonical;
    2903                 :             : 
    2904                 :       31832 :   gfc_finish_type (typenode);
    2905                 :       31832 :   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
    2906                 :       31832 :   if (derived->module && derived->ns->proc_name
    2907                 :       18778 :       && derived->ns->proc_name->attr.flavor == FL_MODULE)
    2908                 :             :     {
    2909                 :       17709 :       if (derived->ns->proc_name->backend_decl
    2910                 :       17695 :           && TREE_CODE (derived->ns->proc_name->backend_decl)
    2911                 :             :              == NAMESPACE_DECL)
    2912                 :             :         {
    2913                 :       17695 :           TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
    2914                 :       17695 :           DECL_CONTEXT (TYPE_STUB_DECL (typenode))
    2915                 :       35390 :             = derived->ns->proc_name->backend_decl;
    2916                 :             :         }
    2917                 :             :     }
    2918                 :             : 
    2919                 :       31832 :   derived->backend_decl = typenode;
    2920                 :             : 
    2921                 :       41304 : copy_derived_types:
    2922                 :             : 
    2923                 :      168636 :   for (c = derived->components; c; c = c->next)
    2924                 :             :     {
    2925                 :             :       /* Do not add a caf_token field for class container components.  */
    2926                 :      127332 :       if ((codimen || coarray_flag)
    2927                 :         653 :           && !c->attr.dimension && !c->attr.codimension
    2928                 :         342 :           && (c->attr.allocatable || c->attr.pointer)
    2929                 :          78 :           && !derived->attr.is_class)
    2930                 :             :         {
    2931                 :             :           /* Provide sufficient space to hold "_caf_symbol".  */
    2932                 :          76 :           char caf_name[GFC_MAX_SYMBOL_LEN + 6];
    2933                 :          76 :           gfc_component *token;
    2934                 :          76 :           snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
    2935                 :          76 :           token = gfc_find_component (derived, caf_name, true, true, NULL);
    2936                 :          76 :           gcc_assert (token);
    2937                 :          76 :           c->caf_token = token->backend_decl;
    2938                 :          76 :           suppress_warning (c->caf_token);
    2939                 :             :         }
    2940                 :             :     }
    2941                 :             : 
    2942                 :      269622 :   for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
    2943                 :             :     {
    2944                 :      269081 :       gfc_copy_dt_decls_ifequal (derived, dt, false);
    2945                 :      269081 :       if (dt->dt_next == gfc_derived_types)
    2946                 :             :         break;
    2947                 :             :     }
    2948                 :             : 
    2949                 :       41304 :   return derived->backend_decl;
    2950                 :             : }
    2951                 :             : 
    2952                 :             : 
    2953                 :             : bool
    2954                 :      819891 : gfc_return_by_reference (gfc_symbol * sym)
    2955                 :             : {
    2956                 :      819891 :   if (!sym->attr.function)
    2957                 :             :     return 0;
    2958                 :             : 
    2959                 :      404399 :   if (sym->attr.dimension)
    2960                 :             :     return 1;
    2961                 :             : 
    2962                 :      341265 :   if (sym->ts.type == BT_CHARACTER
    2963                 :       20400 :       && !sym->attr.is_bind_c
    2964                 :       19866 :       && (!sym->attr.result
    2965                 :          16 :           || !sym->ns->proc_name
    2966                 :          16 :           || !sym->ns->proc_name->attr.is_bind_c))
    2967                 :             :     return 1;
    2968                 :             : 
    2969                 :             :   /* Possibly return complex numbers by reference for g77 compatibility.
    2970                 :             :      We don't do this for calls to intrinsics (as the library uses the
    2971                 :             :      -fno-f2c calling convention), nor for calls to functions which always
    2972                 :             :      require an explicit interface, as no compatibility problems can
    2973                 :             :      arise there.  */
    2974                 :      321399 :   if (flag_f2c && sym->ts.type == BT_COMPLEX
    2975                 :             :       && !sym->attr.pointer
    2976                 :             :       && !sym->attr.allocatable
    2977                 :        1800 :       && !sym->attr.intrinsic && !sym->attr.always_explicit)
    2978                 :         624 :     return 1;
    2979                 :             : 
    2980                 :             :   return 0;
    2981                 :             : }
    2982                 :             : 
    2983                 :             : static tree
    2984                 :          96 : gfc_get_mixed_entry_union (gfc_namespace *ns)
    2985                 :             : {
    2986                 :          96 :   tree type;
    2987                 :          96 :   tree *chain = NULL;
    2988                 :          96 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2989                 :          96 :   gfc_entry_list *el, *el2;
    2990                 :             : 
    2991                 :          96 :   gcc_assert (ns->proc_name->attr.mixed_entry_master);
    2992                 :          96 :   gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
    2993                 :             : 
    2994                 :          96 :   snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
    2995                 :             : 
    2996                 :             :   /* Build the type node.  */
    2997                 :          96 :   type = make_node (UNION_TYPE);
    2998                 :             : 
    2999                 :          96 :   TYPE_NAME (type) = get_identifier (name);
    3000                 :             : 
    3001                 :         306 :   for (el = ns->entries; el; el = el->next)
    3002                 :             :     {
    3003                 :             :       /* Search for duplicates.  */
    3004                 :         342 :       for (el2 = ns->entries; el2 != el; el2 = el2->next)
    3005                 :         132 :         if (el2->sym->result == el->sym->result)
    3006                 :             :           break;
    3007                 :             : 
    3008                 :         210 :       if (el == el2)
    3009                 :         210 :         gfc_add_field_to_struct_1 (type,
    3010                 :         210 :                                    get_identifier (el->sym->result->name),
    3011                 :         210 :                                    gfc_sym_type (el->sym->result), &chain);
    3012                 :             :     }
    3013                 :             : 
    3014                 :             :   /* Finish off the type.  */
    3015                 :          96 :   gfc_finish_type (type);
    3016                 :          96 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
    3017                 :          96 :   return type;
    3018                 :             : }
    3019                 :             : 
    3020                 :             : /* Create a "fn spec" based on the formal arguments;
    3021                 :             :    cf. create_function_arglist.  */
    3022                 :             : 
    3023                 :             : static tree
    3024                 :       95654 : create_fn_spec (gfc_symbol *sym, tree fntype)
    3025                 :             : {
    3026                 :       95654 :   char spec[150];
    3027                 :       95654 :   size_t spec_len;
    3028                 :       95654 :   gfc_formal_arglist *f;
    3029                 :       95654 :   tree tmp;
    3030                 :             : 
    3031                 :       95654 :   memset (&spec, 0, sizeof (spec));
    3032                 :       95654 :   spec[0] = '.';
    3033                 :       95654 :   spec[1] = ' ';
    3034                 :       95654 :   spec_len = 2;
    3035                 :             : 
    3036                 :       95654 :   if (sym->attr.entry_master)
    3037                 :             :     {
    3038                 :         632 :       spec[spec_len++] = 'R';
    3039                 :         632 :       spec[spec_len++] = ' ';
    3040                 :             :     }
    3041                 :       95654 :   if (gfc_return_by_reference (sym))
    3042                 :             :     {
    3043                 :        8458 :       gfc_symbol *result = sym->result ? sym->result : sym;
    3044                 :             : 
    3045                 :        8458 :       if (result->attr.pointer || sym->attr.proc_pointer)
    3046                 :             :         {
    3047                 :         286 :           spec[spec_len++] = '.';
    3048                 :         286 :           spec[spec_len++] = ' ';
    3049                 :             :         }
    3050                 :             :       else
    3051                 :             :         {
    3052                 :        8172 :           spec[spec_len++] = 'w';
    3053                 :        8172 :           spec[spec_len++] = ' ';
    3054                 :             :         }
    3055                 :        8458 :       if (sym->ts.type == BT_CHARACTER)
    3056                 :             :         {
    3057                 :        2699 :           if (!sym->ts.u.cl->length
    3058                 :         468 :               && (sym->attr.allocatable || sym->attr.pointer))
    3059                 :         246 :             spec[spec_len++] = 'w';
    3060                 :             :           else
    3061                 :        2453 :             spec[spec_len++] = 'R';
    3062                 :        2699 :           spec[spec_len++] = ' ';
    3063                 :             :         }
    3064                 :             :     }
    3065                 :             : 
    3066                 :      219484 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3067                 :      123830 :     if (spec_len < sizeof (spec))
    3068                 :             :       {
    3069                 :      123830 :         bool is_class = false;
    3070                 :      123830 :         bool is_pointer = false;
    3071                 :             : 
    3072                 :      123830 :         if (f->sym)
    3073                 :             :           {
    3074                 :        8648 :             is_class = f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
    3075                 :      132374 :               && f->sym->attr.class_ok;
    3076                 :      123726 :             is_pointer = is_class ? CLASS_DATA (f->sym)->attr.class_pointer
    3077                 :      115078 :                                   : f->sym->attr.pointer;
    3078                 :             :           }
    3079                 :             : 
    3080                 :      123830 :         if (f->sym == NULL || is_pointer || f->sym->attr.target
    3081                 :      119950 :             || f->sym->attr.external || f->sym->attr.cray_pointer
    3082                 :      117103 :             || (f->sym->ts.type == BT_DERIVED
    3083                 :       21002 :                 && (f->sym->ts.u.derived->attr.proc_pointer_comp
    3084                 :       21002 :                     || f->sym->ts.u.derived->attr.pointer_comp))
    3085                 :      114517 :             || (is_class
    3086                 :        7787 :                 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
    3087                 :        7787 :                     || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
    3088                 :      113263 :             || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
    3089                 :             :           {
    3090                 :       17725 :             spec[spec_len++] = '.';
    3091                 :       17725 :             spec[spec_len++] = ' ';
    3092                 :             :           }
    3093                 :      106105 :         else if (f->sym->attr.intent == INTENT_IN)
    3094                 :             :           {
    3095                 :       46136 :             spec[spec_len++] = 'r';
    3096                 :       46136 :             spec[spec_len++] = ' ';
    3097                 :             :           }
    3098                 :       59969 :         else if (f->sym)
    3099                 :             :           {
    3100                 :       59969 :             spec[spec_len++] = 'w';
    3101                 :       59969 :             spec[spec_len++] = ' ';
    3102                 :             :           }
    3103                 :             :       }
    3104                 :             : 
    3105                 :       95654 :   tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
    3106                 :       95654 :   tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
    3107                 :       95654 :   return build_type_attribute_variant (fntype, tmp);
    3108                 :             : }
    3109                 :             : 
    3110                 :             : 
    3111                 :             : /* NOTE: The returned function type must match the argument list created by
    3112                 :             :    create_function_arglist.  */
    3113                 :             : 
    3114                 :             : tree
    3115                 :       97439 : gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
    3116                 :             :                        const char *fnspec)
    3117                 :             : {
    3118                 :       97439 :   tree type;
    3119                 :       97439 :   vec<tree, va_gc> *typelist = NULL;
    3120                 :       97439 :   vec<tree, va_gc> *hidden_typelist = NULL;
    3121                 :       97439 :   gfc_formal_arglist *f;
    3122                 :       97439 :   gfc_symbol *arg;
    3123                 :       97439 :   int alternate_return = 0;
    3124                 :       97439 :   bool is_varargs = true;
    3125                 :             : 
    3126                 :             :   /* Make sure this symbol is a function, a subroutine or the main
    3127                 :             :      program.  */
    3128                 :       97439 :   gcc_assert (sym->attr.flavor == FL_PROCEDURE
    3129                 :             :               || sym->attr.flavor == FL_PROGRAM);
    3130                 :             : 
    3131                 :             :   /* To avoid recursing infinitely on recursive types, we use error_mark_node
    3132                 :             :      so that they can be detected here and handled further down.  */
    3133                 :       97439 :   if (sym->backend_decl == NULL)
    3134                 :       97235 :     sym->backend_decl = error_mark_node;
    3135                 :         204 :   else if (sym->backend_decl == error_mark_node)
    3136                 :          27 :     goto arg_type_list_done;
    3137                 :         177 :   else if (sym->attr.proc_pointer)
    3138                 :           0 :     return TREE_TYPE (TREE_TYPE (sym->backend_decl));
    3139                 :             :   else
    3140                 :         177 :     return TREE_TYPE (sym->backend_decl);
    3141                 :             : 
    3142                 :       97235 :   if (sym->attr.entry_master)
    3143                 :             :     /* Additional parameter for selecting an entry point.  */
    3144                 :         632 :     vec_safe_push (typelist, gfc_array_index_type);
    3145                 :             : 
    3146                 :       97235 :   if (sym->result)
    3147                 :       29014 :     arg = sym->result;
    3148                 :             :   else
    3149                 :             :     arg = sym;
    3150                 :             : 
    3151                 :       97235 :   if (arg->ts.type == BT_CHARACTER)
    3152                 :        3002 :     gfc_conv_const_charlen (arg->ts.u.cl);
    3153                 :             : 
    3154                 :             :   /* Some functions we use an extra parameter for the return value.  */
    3155                 :       97235 :   if (gfc_return_by_reference (sym))
    3156                 :             :     {
    3157                 :        9984 :       type = gfc_sym_type (arg);
    3158                 :        9984 :       if (arg->ts.type == BT_COMPLEX
    3159                 :        9663 :           || arg->attr.dimension
    3160                 :        1479 :           || arg->ts.type == BT_CHARACTER)
    3161                 :        9984 :         type = build_reference_type (type);
    3162                 :             : 
    3163                 :        9984 :       vec_safe_push (typelist, type);
    3164                 :        9984 :       if (arg->ts.type == BT_CHARACTER)
    3165                 :             :         {
    3166                 :        2939 :           if (!arg->ts.deferred)
    3167                 :             :             /* Transfer by value.  */
    3168                 :        2645 :             vec_safe_push (typelist, gfc_charlen_type_node);
    3169                 :             :           else
    3170                 :             :             /* Deferred character lengths are transferred by reference
    3171                 :             :                so that the value can be returned.  */
    3172                 :         294 :             vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
    3173                 :             :         }
    3174                 :             :     }
    3175                 :       97235 :   if (sym->backend_decl == error_mark_node && actual_args != NULL
    3176                 :       13392 :       && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
    3177                 :        1046 :                                  || sym->attr.proc == PROC_UNKNOWN))
    3178                 :         791 :     gfc_get_formal_from_actual_arglist (sym, actual_args);
    3179                 :             : 
    3180                 :             :   /* Build the argument types for the function.  */
    3181                 :      225636 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3182                 :             :     {
    3183                 :      128401 :       arg = f->sym;
    3184                 :      128401 :       if (arg)
    3185                 :             :         {
    3186                 :             :           /* Evaluate constant character lengths here so that they can be
    3187                 :             :              included in the type.  */
    3188                 :      128297 :           if (arg->ts.type == BT_CHARACTER)
    3189                 :       11611 :             gfc_conv_const_charlen (arg->ts.u.cl);
    3190                 :             : 
    3191                 :      128297 :           if (arg->attr.flavor == FL_PROCEDURE)
    3192                 :             :             {
    3193                 :         961 :               type = gfc_get_function_type (arg);
    3194                 :         961 :               type = build_pointer_type (type);
    3195                 :             :             }
    3196                 :             :           else
    3197                 :      127336 :             type = gfc_sym_type (arg, sym->attr.is_bind_c);
    3198                 :             : 
    3199                 :             :           /* Parameter Passing Convention
    3200                 :             : 
    3201                 :             :              We currently pass all parameters by reference.
    3202                 :             :              Parameters with INTENT(IN) could be passed by value.
    3203                 :             :              The problem arises if a function is called via an implicit
    3204                 :             :              prototype. In this situation the INTENT is not known.
    3205                 :             :              For this reason all parameters to global functions must be
    3206                 :             :              passed by reference.  Passing by value would potentially
    3207                 :             :              generate bad code.  Worse there would be no way of telling that
    3208                 :             :              this code was bad, except that it would give incorrect results.
    3209                 :             : 
    3210                 :             :              Contained procedures could pass by value as these are never
    3211                 :             :              used without an explicit interface, and cannot be passed as
    3212                 :             :              actual parameters for a dummy procedure.  */
    3213                 :             : 
    3214                 :      128297 :           vec_safe_push (typelist, type);
    3215                 :             :         }
    3216                 :             :       else
    3217                 :             :         {
    3218                 :         104 :           if (sym->attr.subroutine)
    3219                 :      128401 :             alternate_return = 1;
    3220                 :             :         }
    3221                 :             :     }
    3222                 :             : 
    3223                 :             :   /* Add hidden arguments.  */
    3224                 :      225636 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3225                 :             :     {
    3226                 :      128401 :       arg = f->sym;
    3227                 :             :       /* Add hidden string length parameters.  */
    3228                 :      128401 :       if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
    3229                 :             :         {
    3230                 :        9542 :           if (!arg->ts.deferred)
    3231                 :             :             /* Transfer by value.  */
    3232                 :        9063 :             type = gfc_charlen_type_node;
    3233                 :             :           else
    3234                 :             :             /* Deferred character lengths are transferred by reference
    3235                 :             :                so that the value can be returned.  */
    3236                 :         479 :             type = build_pointer_type (gfc_charlen_type_node);
    3237                 :             : 
    3238                 :        9542 :           vec_safe_push (hidden_typelist, type);
    3239                 :             :         }
    3240                 :             :       /* For scalar intrinsic types, VALUE passes the value,
    3241                 :             :          hence, the optional status cannot be transferred via a NULL pointer.
    3242                 :             :          Thus, we will use a hidden argument in that case.  */
    3243                 :             :       if (arg
    3244                 :             :           && arg->attr.optional
    3245                 :             :           && arg->attr.value
    3246                 :      128297 :           && !arg->attr.dimension
    3247                 :         456 :           && arg->ts.type != BT_CLASS
    3248                 :             :           && !gfc_bt_struct (arg->ts.type))
    3249                 :         456 :         vec_safe_push (typelist, boolean_type_node);
    3250                 :             :       /* Coarrays which are descriptorless or assumed-shape pass with
    3251                 :             :          -fcoarray=lib the token and the offset as hidden arguments.  */
    3252                 :         560 :       if (arg
    3253                 :      128297 :           && flag_coarray == GFC_FCOARRAY_LIB
    3254                 :         372 :           && ((arg->ts.type != BT_CLASS
    3255                 :             :                && arg->attr.codimension
    3256                 :         360 :                && !arg->attr.allocatable)
    3257                 :         322 :               || (arg->ts.type == BT_CLASS
    3258                 :          12 :                   && CLASS_DATA (arg)->attr.codimension
    3259                 :          12 :                   && !CLASS_DATA (arg)->attr.allocatable)))
    3260                 :             :         {
    3261                 :          59 :           vec_safe_push (hidden_typelist, pvoid_type_node);  /* caf_token.  */
    3262                 :          59 :           vec_safe_push (hidden_typelist, gfc_array_index_type);  /* caf_offset.  */
    3263                 :             :         }
    3264                 :             :     }
    3265                 :             : 
    3266                 :             :   /* Put hidden character length, caf_token, caf_offset at the end.  */
    3267                 :      103918 :   vec_safe_reserve (typelist, vec_safe_length (hidden_typelist));
    3268                 :       97235 :   vec_safe_splice (typelist, hidden_typelist);
    3269                 :             : 
    3270                 :       97235 :   if (!vec_safe_is_empty (typelist)
    3271                 :             :       || sym->attr.is_main_program
    3272                 :       38405 :       || sym->attr.if_source != IFSRC_UNKNOWN)
    3273                 :             :     is_varargs = false;
    3274                 :             : 
    3275                 :       97235 :   if (sym->backend_decl == error_mark_node)
    3276                 :       97235 :     sym->backend_decl = NULL_TREE;
    3277                 :             : 
    3278                 :       97262 : arg_type_list_done:
    3279                 :             : 
    3280                 :       97262 :   if (alternate_return)
    3281                 :          74 :     type = integer_type_node;
    3282                 :       97188 :   else if (!sym->attr.function || gfc_return_by_reference (sym))
    3283                 :       77763 :     type = void_type_node;
    3284                 :       19425 :   else if (sym->attr.mixed_entry_master)
    3285                 :          96 :     type = gfc_get_mixed_entry_union (sym->ns);
    3286                 :       19329 :   else if (flag_f2c && sym->ts.type == BT_REAL
    3287                 :         393 :            && sym->ts.kind == gfc_default_real_kind
    3288                 :             :            && !sym->attr.pointer
    3289                 :         219 :            && !sym->attr.allocatable
    3290                 :         171 :            && !sym->attr.always_explicit)
    3291                 :             :     {
    3292                 :             :       /* Special case: f2c calling conventions require that (scalar)
    3293                 :             :          default REAL functions return the C type double instead.  f2c
    3294                 :             :          compatibility is only an issue with functions that don't
    3295                 :             :          require an explicit interface, as only these could be
    3296                 :             :          implemented in Fortran 77.  */
    3297                 :         171 :       sym->ts.kind = gfc_default_double_kind;
    3298                 :         171 :       type = gfc_typenode_for_spec (&sym->ts);
    3299                 :         171 :       sym->ts.kind = gfc_default_real_kind;
    3300                 :             :     }
    3301                 :       19158 :   else if (sym->result && sym->result->attr.proc_pointer)
    3302                 :             :     /* Procedure pointer return values.  */
    3303                 :             :     {
    3304                 :         443 :       if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
    3305                 :             :         {
    3306                 :             :           /* Unset proc_pointer as gfc_get_function_type
    3307                 :             :              is called recursively.  */
    3308                 :         151 :           sym->result->attr.proc_pointer = 0;
    3309                 :         151 :           type = build_pointer_type (gfc_get_function_type (sym->result));
    3310                 :         151 :           sym->result->attr.proc_pointer = 1;
    3311                 :             :         }
    3312                 :             :       else
    3313                 :         292 :        type = gfc_sym_type (sym->result);
    3314                 :             :     }
    3315                 :             :   else
    3316                 :       18715 :     type = gfc_sym_type (sym);
    3317                 :             : 
    3318                 :       97262 :   if (is_varargs)
    3319                 :             :     /* This should be represented as an unprototyped type, not a type
    3320                 :             :        with (...) prototype.  */
    3321                 :        1856 :     type = build_function_type (type, NULL_TREE);
    3322                 :             :   else
    3323                 :      213066 :     type = build_function_type_vec (type, typelist);
    3324                 :             : 
    3325                 :             :   /* If we were passed an fn spec, add it here, otherwise determine it from
    3326                 :             :      the formal arguments.  */
    3327                 :       97262 :   if (fnspec)
    3328                 :             :     {
    3329                 :        1608 :       tree tmp;
    3330                 :        1608 :       int spec_len = strlen (fnspec);
    3331                 :        1608 :       tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec));
    3332                 :        1608 :       tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type));
    3333                 :        1608 :       type = build_type_attribute_variant (type, tmp);
    3334                 :             :     }
    3335                 :             :   else
    3336                 :       95654 :     type = create_fn_spec (sym, type);
    3337                 :             : 
    3338                 :       97262 :   return type;
    3339                 :             : }
    3340                 :             : 
    3341                 :             : /* Language hooks for middle-end access to type nodes.  */
    3342                 :             : 
    3343                 :             : /* Return an integer type with BITS bits of precision,
    3344                 :             :    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
    3345                 :             : 
    3346                 :             : tree
    3347                 :      810496 : gfc_type_for_size (unsigned bits, int unsignedp)
    3348                 :             : {
    3349                 :      810496 :   if (!unsignedp)
    3350                 :             :     {
    3351                 :             :       int i;
    3352                 :      351986 :       for (i = 0; i <= MAX_INT_KINDS; ++i)
    3353                 :             :         {
    3354                 :      351986 :           tree type = gfc_integer_types[i];
    3355                 :      351986 :           if (type && bits == TYPE_PRECISION (type))
    3356                 :       95683 :             return type;
    3357                 :             :         }
    3358                 :             : 
    3359                 :             :       /* Handle TImode as a special case because it is used by some backends
    3360                 :             :          (e.g. ARM) even though it is not available for normal use.  */
    3361                 :             : #if HOST_BITS_PER_WIDE_INT >= 64
    3362                 :           0 :       if (bits == TYPE_PRECISION (intTI_type_node))
    3363                 :             :         return intTI_type_node;
    3364                 :             : #endif
    3365                 :             : 
    3366                 :           0 :       if (bits <= TYPE_PRECISION (intQI_type_node))
    3367                 :             :         return intQI_type_node;
    3368                 :           0 :       if (bits <= TYPE_PRECISION (intHI_type_node))
    3369                 :             :         return intHI_type_node;
    3370                 :           0 :       if (bits <= TYPE_PRECISION (intSI_type_node))
    3371                 :             :         return intSI_type_node;
    3372                 :           0 :       if (bits <= TYPE_PRECISION (intDI_type_node))
    3373                 :             :         return intDI_type_node;
    3374                 :           0 :       if (bits <= TYPE_PRECISION (intTI_type_node))
    3375                 :             :         return intTI_type_node;
    3376                 :             :     }
    3377                 :             :   else
    3378                 :             :     {
    3379                 :      714813 :       if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
    3380                 :             :         return unsigned_intQI_type_node;
    3381                 :      652900 :       if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
    3382                 :             :         return unsigned_intHI_type_node;
    3383                 :      620971 :       if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
    3384                 :             :         return unsigned_intSI_type_node;
    3385                 :      579458 :       if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
    3386                 :             :         return unsigned_intDI_type_node;
    3387                 :       30054 :       if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
    3388                 :             :         return unsigned_intTI_type_node;
    3389                 :             :     }
    3390                 :             : 
    3391                 :             :   return NULL_TREE;
    3392                 :             : }
    3393                 :             : 
    3394                 :             : /* Return a data type that has machine mode MODE.  If the mode is an
    3395                 :             :    integer, then UNSIGNEDP selects between signed and unsigned types.  */
    3396                 :             : 
    3397                 :             : tree
    3398                 :      750455 : gfc_type_for_mode (machine_mode mode, int unsignedp)
    3399                 :             : {
    3400                 :      750455 :   int i;
    3401                 :      750455 :   tree *base;
    3402                 :      750455 :   scalar_int_mode int_mode;
    3403                 :             : 
    3404                 :      750455 :   if (GET_MODE_CLASS (mode) == MODE_FLOAT)
    3405                 :             :     base = gfc_real_types;
    3406                 :      743217 :   else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
    3407                 :             :     base = gfc_complex_types;
    3408                 :      563105 :   else if (is_a <scalar_int_mode> (mode, &int_mode))
    3409                 :             :     {
    3410                 :      561147 :       tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp);
    3411                 :      561147 :       return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
    3412                 :             :     }
    3413                 :        1958 :   else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
    3414                 :        1958 :            && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    3415                 :             :     {
    3416                 :           0 :       unsigned int elem_bits = vector_element_size (GET_MODE_PRECISION (mode),
    3417                 :             :                                                     GET_MODE_NUNITS (mode));
    3418                 :           0 :       tree bool_type = build_nonstandard_boolean_type (elem_bits);
    3419                 :           0 :       return build_vector_type_for_mode (bool_type, mode);
    3420                 :             :     }
    3421                 :          35 :   else if (VECTOR_MODE_P (mode)
    3422                 :        3913 :            && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    3423                 :             :     {
    3424                 :        1955 :       machine_mode inner_mode = GET_MODE_INNER (mode);
    3425                 :        1955 :       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
    3426                 :        1955 :       if (inner_type != NULL_TREE)
    3427                 :        1955 :         return build_vector_type_for_mode (inner_type, mode);
    3428                 :             :       return NULL_TREE;
    3429                 :             :     }
    3430                 :             :   else
    3431                 :           3 :     return NULL_TREE;
    3432                 :             : 
    3433                 :      731612 :   for (i = 0; i <= MAX_REAL_KINDS; ++i)
    3434                 :             :     {
    3435                 :      671894 :       tree type = base[i];
    3436                 :      671894 :       if (type && mode == TYPE_MODE (type))
    3437                 :      127632 :         return type;
    3438                 :             :     }
    3439                 :             : 
    3440                 :             :   return NULL_TREE;
    3441                 :             : }
    3442                 :             : 
    3443                 :             : /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
    3444                 :             :    in that case.  */
    3445                 :             : 
    3446                 :             : bool
    3447                 :      352919 : gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
    3448                 :             : {
    3449                 :      352919 :   int rank, dim;
    3450                 :      352919 :   bool indirect = false;
    3451                 :      352919 :   tree etype, ptype, t, base_decl;
    3452                 :      352919 :   tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
    3453                 :      352919 :   tree lower_suboff, upper_suboff, stride_suboff;
    3454                 :      352919 :   tree dtype, field, rank_off;
    3455                 :             : 
    3456                 :      352919 :   if (! GFC_DESCRIPTOR_TYPE_P (type))
    3457                 :             :     {
    3458                 :      226730 :       if (! POINTER_TYPE_P (type))
    3459                 :             :         return false;
    3460                 :      141140 :       type = TREE_TYPE (type);
    3461                 :      141140 :       if (! GFC_DESCRIPTOR_TYPE_P (type))
    3462                 :             :         return false;
    3463                 :             :       indirect = true;
    3464                 :             :     }
    3465                 :             : 
    3466                 :      247481 :   rank = GFC_TYPE_ARRAY_RANK (type);
    3467                 :      247481 :   if (rank >= (int) (ARRAY_SIZE (info->dimen)))
    3468                 :             :     return false;
    3469                 :             : 
    3470                 :      247481 :   etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
    3471                 :      247481 :   gcc_assert (POINTER_TYPE_P (etype));
    3472                 :      247481 :   etype = TREE_TYPE (etype);
    3473                 :             : 
    3474                 :             :   /* If the type is not a scalar coarray.  */
    3475                 :      247481 :   if (TREE_CODE (etype) == ARRAY_TYPE)
    3476                 :      247458 :     etype = TREE_TYPE (etype);
    3477                 :             : 
    3478                 :             :   /* Can't handle variable sized elements yet.  */
    3479                 :      247481 :   if (int_size_in_bytes (etype) <= 0)
    3480                 :             :     return false;
    3481                 :             :   /* Nor non-constant lower bounds in assumed shape arrays.  */
    3482                 :      230356 :   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
    3483                 :      230356 :       || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    3484                 :             :     {
    3485                 :       67581 :       for (dim = 0; dim < rank; dim++)
    3486                 :       40671 :         if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
    3487                 :       40671 :             || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
    3488                 :             :           return false;
    3489                 :             :     }
    3490                 :             : 
    3491                 :      230274 :   memset (info, '\0', sizeof (*info));
    3492                 :      230274 :   info->ndimensions = rank;
    3493                 :      230274 :   info->ordering = array_descr_ordering_column_major;
    3494                 :      230274 :   info->element_type = etype;
    3495                 :      230274 :   ptype = build_pointer_type (gfc_array_index_type);
    3496                 :      230274 :   base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
    3497                 :      230274 :   if (!base_decl)
    3498                 :             :     {
    3499                 :      335532 :       base_decl = build_debug_expr_decl (indirect
    3500                 :      111838 :                                          ? build_pointer_type (ptype) : ptype);
    3501                 :      223694 :       GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
    3502                 :             :     }
    3503                 :      230274 :   info->base_decl = base_decl;
    3504                 :      230274 :   if (indirect)
    3505                 :      113169 :     base_decl = build1 (INDIRECT_REF, ptype, base_decl);
    3506                 :             : 
    3507                 :      230274 :   gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
    3508                 :             :                                        &dim_off, &dim_size, &stride_suboff,
    3509                 :             :                                        &lower_suboff, &upper_suboff);
    3510                 :             : 
    3511                 :      230274 :   t = fold_build_pointer_plus (base_decl, span_off);
    3512                 :      230274 :   elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3513                 :             : 
    3514                 :      230274 :   t = base_decl;
    3515                 :      230274 :   if (!integer_zerop (data_off))
    3516                 :           0 :     t = fold_build_pointer_plus (t, data_off);
    3517                 :      230274 :   t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
    3518                 :      230274 :   info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
    3519                 :      230274 :   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
    3520                 :       20855 :     info->allocated = build2 (NE_EXPR, logical_type_node,
    3521                 :             :                               info->data_location, null_pointer_node);
    3522                 :      209419 :   else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
    3523                 :      209419 :            || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
    3524                 :       14435 :     info->associated = build2 (NE_EXPR, logical_type_node,
    3525                 :             :                                info->data_location, null_pointer_node);
    3526                 :      230274 :   if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
    3527                 :      222379 :        || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
    3528                 :      234819 :       && dwarf_version >= 5)
    3529                 :             :     {
    3530                 :       12440 :       rank = 1;
    3531                 :       12440 :       info->ndimensions = 1;
    3532                 :       12440 :       t = base_decl;
    3533                 :       12440 :       if (!integer_zerop (dtype_off))
    3534                 :       12440 :         t = fold_build_pointer_plus (t, dtype_off);
    3535                 :       12440 :       dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
    3536                 :       12440 :       field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
    3537                 :       12440 :       rank_off = byte_position (field);
    3538                 :       12440 :       if (!integer_zerop (dtype_off))
    3539                 :       12440 :         t = fold_build_pointer_plus (t, rank_off);
    3540                 :             : 
    3541                 :       12440 :       t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t);
    3542                 :       12440 :       t = build1 (INDIRECT_REF, TREE_TYPE (field), t);
    3543                 :       12440 :       info->rank = t;
    3544                 :       12440 :       t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
    3545                 :       12440 :       t = size_binop (MULT_EXPR, t, dim_size);
    3546                 :       12440 :       dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
    3547                 :             :     }
    3548                 :             : 
    3549                 :      556540 :   for (dim = 0; dim < rank; dim++)
    3550                 :             :     {
    3551                 :      326266 :       t = fold_build_pointer_plus (base_decl,
    3552                 :             :                                    size_binop (PLUS_EXPR,
    3553                 :             :                                                dim_off, lower_suboff));
    3554                 :      326266 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3555                 :      326266 :       info->dimen[dim].lower_bound = t;
    3556                 :      326266 :       t = fold_build_pointer_plus (base_decl,
    3557                 :             :                                    size_binop (PLUS_EXPR,
    3558                 :             :                                                dim_off, upper_suboff));
    3559                 :      326266 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3560                 :      326266 :       info->dimen[dim].upper_bound = t;
    3561                 :      326266 :       if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
    3562                 :      326266 :           || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    3563                 :             :         {
    3564                 :             :           /* Assumed shape arrays have known lower bounds.  */
    3565                 :       40589 :           info->dimen[dim].upper_bound
    3566                 :       40589 :             = build2 (MINUS_EXPR, gfc_array_index_type,
    3567                 :             :                       info->dimen[dim].upper_bound,
    3568                 :             :                       info->dimen[dim].lower_bound);
    3569                 :       40589 :           info->dimen[dim].lower_bound
    3570                 :       40589 :             = fold_convert (gfc_array_index_type,
    3571                 :             :                             GFC_TYPE_ARRAY_LBOUND (type, dim));
    3572                 :       40589 :           info->dimen[dim].upper_bound
    3573                 :       40589 :             = build2 (PLUS_EXPR, gfc_array_index_type,
    3574                 :             :                       info->dimen[dim].lower_bound,
    3575                 :             :                       info->dimen[dim].upper_bound);
    3576                 :             :         }
    3577                 :      326266 :       t = fold_build_pointer_plus (base_decl,
    3578                 :             :                                    size_binop (PLUS_EXPR,
    3579                 :             :                                                dim_off, stride_suboff));
    3580                 :      326266 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3581                 :      326266 :       t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
    3582                 :      326266 :       info->dimen[dim].stride = t;
    3583                 :      326266 :       if (dim + 1 < rank)
    3584                 :       96014 :         dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
    3585                 :             :     }
    3586                 :             : 
    3587                 :             :   return true;
    3588                 :             : }
    3589                 :             : 
    3590                 :             : 
    3591                 :             : /* Create a type to handle vector subscripts for coarray library calls. It
    3592                 :             :    has the form:
    3593                 :             :      struct caf_vector_t {
    3594                 :             :        size_t nvec;  // size of the vector
    3595                 :             :        union {
    3596                 :             :          struct {
    3597                 :             :            void *vector;
    3598                 :             :            int kind;
    3599                 :             :          } v;
    3600                 :             :          struct {
    3601                 :             :            ptrdiff_t lower_bound;
    3602                 :             :            ptrdiff_t upper_bound;
    3603                 :             :            ptrdiff_t stride;
    3604                 :             :          } triplet;
    3605                 :             :        } u;
    3606                 :             :      }
    3607                 :             :    where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
    3608                 :             :    size in case of DIMEN_VECTOR, where kind is the integer type of the vector.  */
    3609                 :             : 
    3610                 :             : tree
    3611                 :           0 : gfc_get_caf_vector_type (int dim)
    3612                 :             : {
    3613                 :           0 :   static tree vector_types[GFC_MAX_DIMENSIONS];
    3614                 :           0 :   static tree vec_type = NULL_TREE;
    3615                 :           0 :   tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
    3616                 :             : 
    3617                 :           0 :   if (vector_types[dim-1] != NULL_TREE)
    3618                 :             :     return vector_types[dim-1];
    3619                 :             : 
    3620                 :           0 :   if (vec_type == NULL_TREE)
    3621                 :             :     {
    3622                 :           0 :       chain = 0;
    3623                 :           0 :       vect_struct_type = make_node (RECORD_TYPE);
    3624                 :           0 :       tmp = gfc_add_field_to_struct_1 (vect_struct_type,
    3625                 :             :                                        get_identifier ("vector"),
    3626                 :             :                                        pvoid_type_node, &chain);
    3627                 :           0 :       suppress_warning (tmp);
    3628                 :           0 :       tmp = gfc_add_field_to_struct_1 (vect_struct_type,
    3629                 :             :                                        get_identifier ("kind"),
    3630                 :             :                                        integer_type_node, &chain);
    3631                 :           0 :       suppress_warning (tmp);
    3632                 :           0 :       gfc_finish_type (vect_struct_type);
    3633                 :             : 
    3634                 :           0 :       chain = 0;
    3635                 :           0 :       triplet_struct_type = make_node (RECORD_TYPE);
    3636                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
    3637                 :             :                                        get_identifier ("lower_bound"),
    3638                 :             :                                        gfc_array_index_type, &chain);
    3639                 :           0 :       suppress_warning (tmp);
    3640                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
    3641                 :             :                                        get_identifier ("upper_bound"),
    3642                 :             :                                        gfc_array_index_type, &chain);
    3643                 :           0 :       suppress_warning (tmp);
    3644                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
    3645                 :             :                                        gfc_array_index_type, &chain);
    3646                 :           0 :       suppress_warning (tmp);
    3647                 :           0 :       gfc_finish_type (triplet_struct_type);
    3648                 :             : 
    3649                 :           0 :       chain = 0;
    3650                 :           0 :       union_type = make_node (UNION_TYPE);
    3651                 :           0 :       tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
    3652                 :             :                                        vect_struct_type, &chain);
    3653                 :           0 :       suppress_warning (tmp);
    3654                 :           0 :       tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
    3655                 :             :                                        triplet_struct_type, &chain);
    3656                 :           0 :       suppress_warning (tmp);
    3657                 :           0 :       gfc_finish_type (union_type);
    3658                 :             : 
    3659                 :           0 :       chain = 0;
    3660                 :           0 :       vec_type = make_node (RECORD_TYPE);
    3661                 :           0 :       tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
    3662                 :             :                                        size_type_node, &chain);
    3663                 :           0 :       suppress_warning (tmp);
    3664                 :           0 :       tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
    3665                 :             :                                        union_type, &chain);
    3666                 :           0 :       suppress_warning (tmp);
    3667                 :           0 :       gfc_finish_type (vec_type);
    3668                 :           0 :       TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
    3669                 :             :     }
    3670                 :             : 
    3671                 :           0 :   tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3672                 :             :                           gfc_rank_cst[dim-1]);
    3673                 :           0 :   vector_types[dim-1] = build_array_type (vec_type, tmp);
    3674                 :           0 :   return vector_types[dim-1];
    3675                 :             : }
    3676                 :             : 
    3677                 :             : 
    3678                 :             : tree
    3679                 :        1741 : gfc_get_caf_reference_type ()
    3680                 :             : {
    3681                 :        1741 :   static tree reference_type = NULL_TREE;
    3682                 :        1741 :   tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
    3683                 :             :       a_struct_type, u_union_type, tmp, *chain;
    3684                 :             : 
    3685                 :        1741 :   if (reference_type != NULL_TREE)
    3686                 :             :     return reference_type;
    3687                 :             : 
    3688                 :          82 :   chain = 0;
    3689                 :          82 :   c_struct_type = make_node (RECORD_TYPE);
    3690                 :          82 :   tmp = gfc_add_field_to_struct_1 (c_struct_type,
    3691                 :             :                                    get_identifier ("offset"),
    3692                 :             :                                    gfc_array_index_type, &chain);
    3693                 :          82 :   suppress_warning (tmp);
    3694                 :          82 :   tmp = gfc_add_field_to_struct_1 (c_struct_type,
    3695                 :             :                                    get_identifier ("caf_token_offset"),
    3696                 :             :                                    gfc_array_index_type, &chain);
    3697                 :          82 :   suppress_warning (tmp);
    3698                 :          82 :   gfc_finish_type (c_struct_type);
    3699                 :             : 
    3700                 :          82 :   chain = 0;
    3701                 :          82 :   s_struct_type = make_node (RECORD_TYPE);
    3702                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3703                 :             :                                    get_identifier ("start"),
    3704                 :             :                                    gfc_array_index_type, &chain);
    3705                 :          82 :   suppress_warning (tmp);
    3706                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3707                 :             :                                    get_identifier ("end"),
    3708                 :             :                                    gfc_array_index_type, &chain);
    3709                 :          82 :   suppress_warning (tmp);
    3710                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3711                 :             :                                    get_identifier ("stride"),
    3712                 :             :                                    gfc_array_index_type, &chain);
    3713                 :          82 :   suppress_warning (tmp);
    3714                 :          82 :   gfc_finish_type (s_struct_type);
    3715                 :             : 
    3716                 :          82 :   chain = 0;
    3717                 :          82 :   v_struct_type = make_node (RECORD_TYPE);
    3718                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3719                 :             :                                    get_identifier ("vector"),
    3720                 :             :                                    pvoid_type_node, &chain);
    3721                 :          82 :   suppress_warning (tmp);
    3722                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3723                 :             :                                    get_identifier ("nvec"),
    3724                 :             :                                    size_type_node, &chain);
    3725                 :          82 :   suppress_warning (tmp);
    3726                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3727                 :             :                                    get_identifier ("kind"),
    3728                 :             :                                    integer_type_node, &chain);
    3729                 :          82 :   suppress_warning (tmp);
    3730                 :          82 :   gfc_finish_type (v_struct_type);
    3731                 :             : 
    3732                 :          82 :   chain = 0;
    3733                 :          82 :   union_type = make_node (UNION_TYPE);
    3734                 :          82 :   tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
    3735                 :             :                                    s_struct_type, &chain);
    3736                 :          82 :   suppress_warning (tmp);
    3737                 :          82 :   tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
    3738                 :             :                                    v_struct_type, &chain);
    3739                 :          82 :   suppress_warning (tmp);
    3740                 :          82 :   gfc_finish_type (union_type);
    3741                 :             : 
    3742                 :          82 :   tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3743                 :             :                           gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
    3744                 :          82 :   dim_union_type = build_array_type (union_type, tmp);
    3745                 :             : 
    3746                 :          82 :   chain = 0;
    3747                 :          82 :   a_struct_type = make_node (RECORD_TYPE);
    3748                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
    3749                 :             :                 build_array_type (unsigned_char_type_node,
    3750                 :             :                                   build_range_type (gfc_array_index_type,
    3751                 :             :                                                     gfc_index_zero_node,
    3752                 :             :                                          gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
    3753                 :             :                 &chain);
    3754                 :          82 :   suppress_warning (tmp);
    3755                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type,
    3756                 :             :                                    get_identifier ("static_array_type"),
    3757                 :             :                                    integer_type_node, &chain);
    3758                 :          82 :   suppress_warning (tmp);
    3759                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
    3760                 :             :                                    dim_union_type, &chain);
    3761                 :          82 :   suppress_warning (tmp);
    3762                 :          82 :   gfc_finish_type (a_struct_type);
    3763                 :             : 
    3764                 :          82 :   chain = 0;
    3765                 :          82 :   u_union_type = make_node (UNION_TYPE);
    3766                 :          82 :   tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
    3767                 :             :                                    c_struct_type, &chain);
    3768                 :          82 :   suppress_warning (tmp);
    3769                 :          82 :   tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
    3770                 :             :                                    a_struct_type, &chain);
    3771                 :          82 :   suppress_warning (tmp);
    3772                 :          82 :   gfc_finish_type (u_union_type);
    3773                 :             : 
    3774                 :          82 :   chain = 0;
    3775                 :          82 :   reference_type = make_node (RECORD_TYPE);
    3776                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
    3777                 :             :                                    build_pointer_type (reference_type), &chain);
    3778                 :          82 :   suppress_warning (tmp);
    3779                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
    3780                 :             :                                    integer_type_node, &chain);
    3781                 :          82 :   suppress_warning (tmp);
    3782                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
    3783                 :             :                                    size_type_node, &chain);
    3784                 :          82 :   suppress_warning (tmp);
    3785                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
    3786                 :             :                                    u_union_type, &chain);
    3787                 :          82 :   suppress_warning (tmp);
    3788                 :          82 :   gfc_finish_type (reference_type);
    3789                 :          82 :   TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
    3790                 :             : 
    3791                 :          82 :   return reference_type;
    3792                 :             : }
    3793                 :             : 
    3794                 :             : static tree
    3795                 :        1328 : gfc_get_cfi_dim_type ()
    3796                 :             : {
    3797                 :        1328 :   static tree CFI_dim_t = NULL;
    3798                 :             : 
    3799                 :        1328 :   if (CFI_dim_t)
    3800                 :             :     return CFI_dim_t;
    3801                 :             : 
    3802                 :         630 :   CFI_dim_t = make_node (RECORD_TYPE);
    3803                 :         630 :   TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
    3804                 :         630 :   TYPE_NAMELESS (CFI_dim_t) = 1;
    3805                 :         630 :   tree field;
    3806                 :         630 :   tree *chain = NULL;
    3807                 :         630 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
    3808                 :             :                                      gfc_array_index_type, &chain);
    3809                 :         630 :   suppress_warning (field);
    3810                 :         630 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
    3811                 :             :                                      gfc_array_index_type, &chain);
    3812                 :         630 :   suppress_warning (field);
    3813                 :         630 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
    3814                 :             :                                      gfc_array_index_type, &chain);
    3815                 :         630 :   suppress_warning (field);
    3816                 :         630 :   gfc_finish_type (CFI_dim_t);
    3817                 :         630 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
    3818                 :         630 :   return CFI_dim_t;
    3819                 :             : }
    3820                 :             : 
    3821                 :             : 
    3822                 :             : /* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
    3823                 :             :    otherwise dim[dimen] is used.  */
    3824                 :             : 
    3825                 :             : tree
    3826                 :       12484 : gfc_get_cfi_type (int dimen, bool restricted)
    3827                 :             : {
    3828                 :       12484 :   gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
    3829                 :             : 
    3830                 :       12484 :   int idx = 2*(dimen + 1) + restricted;
    3831                 :             : 
    3832                 :       12484 :   if (gfc_cfi_descriptor_base[idx])
    3833                 :             :     return gfc_cfi_descriptor_base[idx];
    3834                 :             : 
    3835                 :             :   /* Build the type node.  */
    3836                 :        1506 :   tree CFI_cdesc_t = make_node (RECORD_TYPE);
    3837                 :        1506 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    3838                 :        1506 :   if (dimen != -1)
    3839                 :         957 :     sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
    3840                 :        1506 :   TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
    3841                 :        1506 :   TYPE_NAMELESS (CFI_cdesc_t) = 1;
    3842                 :             : 
    3843                 :        1506 :   tree field;
    3844                 :        1506 :   tree *chain = NULL;
    3845                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
    3846                 :             :                                      (restricted ? prvoid_type_node
    3847                 :             :                                                  : ptr_type_node), &chain);
    3848                 :        1506 :   suppress_warning (field);
    3849                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
    3850                 :             :                                      size_type_node, &chain);
    3851                 :        1506 :   suppress_warning (field);
    3852                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
    3853                 :             :                                      integer_type_node, &chain);
    3854                 :        1506 :   suppress_warning (field);
    3855                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
    3856                 :             :                                      signed_char_type_node, &chain);
    3857                 :        1506 :   suppress_warning (field);
    3858                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
    3859                 :             :                                      signed_char_type_node, &chain);
    3860                 :        1506 :   suppress_warning (field);
    3861                 :        1506 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
    3862                 :             :                                      get_typenode_from_name (INT16_TYPE),
    3863                 :             :                                      &chain);
    3864                 :        1506 :   suppress_warning (field);
    3865                 :             : 
    3866                 :        1506 :   if (dimen != 0)
    3867                 :             :     {
    3868                 :        1328 :       tree range = NULL_TREE;
    3869                 :        1328 :       if (dimen > 0)
    3870                 :         779 :         range = gfc_rank_cst[dimen - 1];
    3871                 :        1328 :       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3872                 :             :                                 range);
    3873                 :        1328 :       tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
    3874                 :        1328 :       field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
    3875                 :             :                                          CFI_dim_t, &chain);
    3876                 :        1328 :       suppress_warning (field);
    3877                 :             :     }
    3878                 :             : 
    3879                 :        1506 :   TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
    3880                 :        1506 :   gfc_finish_type (CFI_cdesc_t);
    3881                 :        1506 :   gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
    3882                 :        1506 :   return CFI_cdesc_t;
    3883                 :             : }
    3884                 :             : 
    3885                 :             : #include "gt-fortran-trans-types.h"
        

Generated by: LCOV version 2.1-beta

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