LCOV - code coverage report
Current view: top level - gcc/fortran - trans-types.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 92.5 % 1758 1627
Test Date: 2024-03-23 14:05:01 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                 :      357505 : tree get_dtype_type_node (void)
     142                 :             : {
     143                 :      357505 :   tree field;
     144                 :      357505 :   tree dtype_node;
     145                 :      357505 :   tree *dtype_chain = NULL;
     146                 :             : 
     147                 :      357505 :   if (dtype_type_node == NULL_TREE)
     148                 :             :     {
     149                 :       29475 :       dtype_node = make_node (RECORD_TYPE);
     150                 :       29475 :       TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
     151                 :       29475 :       TYPE_NAMELESS (dtype_node) = 1;
     152                 :       29475 :       field = gfc_add_field_to_struct_1 (dtype_node,
     153                 :             :                                          get_identifier ("elem_len"),
     154                 :             :                                          size_type_node, &dtype_chain);
     155                 :       29475 :       suppress_warning (field);
     156                 :       29475 :       field = gfc_add_field_to_struct_1 (dtype_node,
     157                 :             :                                          get_identifier ("version"),
     158                 :             :                                          integer_type_node, &dtype_chain);
     159                 :       29475 :       suppress_warning (field);
     160                 :       29475 :       field = gfc_add_field_to_struct_1 (dtype_node,
     161                 :             :                                          get_identifier ("rank"),
     162                 :             :                                          signed_char_type_node, &dtype_chain);
     163                 :       29475 :       suppress_warning (field);
     164                 :       29475 :       field = gfc_add_field_to_struct_1 (dtype_node,
     165                 :             :                                          get_identifier ("type"),
     166                 :             :                                          signed_char_type_node, &dtype_chain);
     167                 :       29475 :       suppress_warning (field);
     168                 :       29475 :       field = gfc_add_field_to_struct_1 (dtype_node,
     169                 :             :                                          get_identifier ("attribute"),
     170                 :             :                                          short_integer_type_node, &dtype_chain);
     171                 :       29475 :       suppress_warning (field);
     172                 :       29475 :       gfc_finish_type (dtype_node);
     173                 :       29475 :       TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
     174                 :       29475 :       dtype_type_node = dtype_node;
     175                 :             :     }
     176                 :      357505 :   return dtype_type_node;
     177                 :             : }
     178                 :             : 
     179                 :             : static int
     180                 :      235920 : get_real_kind_from_node (tree type)
     181                 :             : {
     182                 :      235920 :   int i;
     183                 :             : 
     184                 :      589800 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     185                 :      589800 :     if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
     186                 :      235920 :       return gfc_real_kinds[i].kind;
     187                 :             : 
     188                 :             :   return -4;
     189                 :             : }
     190                 :             : 
     191                 :             : static int
     192                 :      766740 : get_int_kind_from_node (tree type)
     193                 :             : {
     194                 :      766740 :   int i;
     195                 :             : 
     196                 :      766740 :   if (!type)
     197                 :             :     return -2;
     198                 :             : 
     199                 :     2472276 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     200                 :     2472276 :     if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
     201                 :      766740 :       return gfc_integer_kinds[i].kind;
     202                 :             : 
     203                 :             :   return -1;
     204                 :             : }
     205                 :             : 
     206                 :             : static int
     207                 :      471840 : get_int_kind_from_name (const char *name)
     208                 :             : {
     209                 :      471840 :   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                 :        1780 : gfc_get_int_kind_from_width_isofortranenv (int size)
     218                 :             : {
     219                 :        1780 :   int i;
     220                 :             : 
     221                 :             :   /* Look for a kind with matching storage size.  */
     222                 :        4450 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     223                 :        4450 :     if (gfc_integer_kinds[i].bit_size == size)
     224                 :        1780 :       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                 :        1335 : gfc_get_real_kind_from_width_isofortranenv (int size)
     242                 :             : {
     243                 :        1335 :   int digits, i, kind;
     244                 :             : 
     245                 :        1335 :   size /= 8;
     246                 :             : 
     247                 :        1335 :   kind = -1;
     248                 :        1335 :   digits = 0;
     249                 :             : 
     250                 :             :   /* Look for a kind with matching storage size.  */
     251                 :        6675 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     252                 :        5340 :     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
     253                 :             :       {
     254                 :        1776 :         if (gfc_real_kinds[i].digits > digits)
     255                 :             :           {
     256                 :        1776 :             digits = gfc_real_kinds[i].digits;
     257                 :        1776 :             kind = gfc_real_kinds[i].kind;
     258                 :             :           }
     259                 :             :       }
     260                 :             : 
     261                 :        1335 :   if (kind != -1)
     262                 :             :     return kind;
     263                 :             : 
     264                 :             :   /* Look for a kind with larger storage size.  */
     265                 :           0 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     266                 :           0 :     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
     267                 :           0 :       kind = -2;
     268                 :             : 
     269                 :             :   return kind;
     270                 :             : }
     271                 :             : 
     272                 :             : 
     273                 :             : 
     274                 :             : static int
     275                 :      147450 : get_int_kind_from_width (int size)
     276                 :             : {
     277                 :      147450 :   int i;
     278                 :             : 
     279                 :      442350 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     280                 :      441536 :     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                 :       29490 : get_int_kind_from_minimal_width (int size)
     288                 :             : {
     289                 :       29490 :   int i;
     290                 :             : 
     291                 :      147450 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     292                 :      147043 :     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                 :       29490 : gfc_init_c_interop_kinds (void)
     304                 :             : {
     305                 :       29490 :   int i;
     306                 :             : 
     307                 :             :   /* init all pointers in the list to NULL */
     308                 :     1562970 :   for (i = 0; i < ISOCBINDING_NUMBER; i++)
     309                 :             :     {
     310                 :             :       /* Initialize the name and value fields.  */
     311                 :     1533480 :       c_interop_kinds_table[i].name[0] = '\0';
     312                 :     1533480 :       c_interop_kinds_table[i].value = -100;
     313                 :     1533480 :       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                 :       29490 : }
     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                 :       29490 : gfc_init_kinds (void)
     361                 :             : {
     362                 :       29490 :   opt_scalar_int_mode int_mode_iter;
     363                 :       29490 :   opt_scalar_float_mode float_mode_iter;
     364                 :       29490 :   int i_index, r_index, kind;
     365                 :       29490 :   bool saw_i4 = false, saw_i8 = false;
     366                 :       29490 :   bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
     367                 :       29490 :   scalar_mode r16_mode = QImode;
     368                 :       29490 :   scalar_mode composite_mode = QImode;
     369                 :             : 
     370                 :       29490 :   i_index = 0;
     371                 :      235920 :   FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
     372                 :             :     {
     373                 :      206430 :       scalar_int_mode mode = int_mode_iter.require ();
     374                 :      206430 :       int kind, bitsize;
     375                 :             : 
     376                 :      206430 :       if (!targetm.scalar_mode_supported_p (mode))
     377                 :      206430 :         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                 :      147043 :       bitsize = GET_MODE_BITSIZE (mode);
     383                 :      147043 :       if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
     384                 :           0 :         continue;
     385                 :             : 
     386                 :      147043 :       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                 :      147043 :       kind = bitsize / 8;
     391                 :             : 
     392                 :      147043 :       if (kind == 4)
     393                 :             :         saw_i4 = true;
     394                 :      117553 :       if (kind == 8)
     395                 :       29490 :         saw_i8 = true;
     396                 :             : 
     397                 :      147043 :       gfc_integer_kinds[i_index].kind = kind;
     398                 :      147043 :       gfc_integer_kinds[i_index].radix = 2;
     399                 :      147043 :       gfc_integer_kinds[i_index].digits = bitsize - 1;
     400                 :      147043 :       gfc_integer_kinds[i_index].bit_size = bitsize;
     401                 :             : 
     402                 :      147043 :       gfc_logical_kinds[i_index].kind = kind;
     403                 :      147043 :       gfc_logical_kinds[i_index].bit_size = bitsize;
     404                 :             : 
     405                 :      147043 :       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                 :       29490 :   if (saw_i8)
     412                 :       29490 :     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                 :       29490 :   gcc_assert(saw_i4);
     418                 :             : 
     419                 :             :   /* Set the maximum integer kind.  Used with at least BOZ constants.  */
     420                 :       29490 :   gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
     421                 :             : 
     422                 :       29490 :   r_index = 0;
     423                 :      206430 :   FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
     424                 :             :     {
     425                 :      176940 :       scalar_float_mode mode = float_mode_iter.require ();
     426                 :      176940 :       const struct real_format *fmt = REAL_MODE_FORMAT (mode);
     427                 :      176940 :       int kind;
     428                 :             : 
     429                 :      176940 :       if (fmt == NULL)
     430                 :      176940 :         continue;
     431                 :      176940 :       if (!targetm.scalar_mode_supported_p (mode))
     432                 :           0 :         continue;
     433                 :             : 
     434                 :     1238580 :       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                 :      176940 :       if (!targetm.libgcc_floating_mode_supported_p (mode))
     442                 :           0 :         continue;
     443                 :      176940 :       if (mode != TYPE_MODE (float_type_node)
     444                 :      147450 :             && (mode != TYPE_MODE (double_type_node))
     445                 :      117960 :             && (mode != TYPE_MODE (long_double_type_node))
     446                 :             : #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
     447                 :      265410 :             && (mode != TFmode)
     448                 :             : #endif
     449                 :             :            )
     450                 :       58980 :         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                 :      117960 :       kind = (GET_MODE_PRECISION (mode) + 7) / 8;
     473                 :             : 
     474                 :      117960 :       if (kind == 4)
     475                 :             :         saw_r4 = true;
     476                 :       88470 :       if (kind == 8)
     477                 :             :         saw_r8 = true;
     478                 :       88470 :       if (kind == 10)
     479                 :             :         saw_r10 = true;
     480                 :       88470 :       if (kind == 16)
     481                 :             :         {
     482                 :       29490 :           saw_r16 = true;
     483                 :       29490 :           r16_mode = mode;
     484                 :             :         }
     485                 :             : 
     486                 :             :       /* Careful we don't stumble a weird internal mode.  */
     487                 :      117960 :       gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
     488                 :             :       /* Or have too many modes for the allocated space.  */
     489                 :       88470 :       gcc_assert (r_index != MAX_REAL_KINDS);
     490                 :             : 
     491                 :      117960 :       gfc_real_kinds[r_index].kind = kind;
     492                 :      117960 :       gfc_real_kinds[r_index].abi_kind = kind;
     493                 :      117960 :       gfc_real_kinds[r_index].radix = fmt->b;
     494                 :      117960 :       gfc_real_kinds[r_index].digits = fmt->p;
     495                 :      117960 :       gfc_real_kinds[r_index].min_exponent = fmt->emin;
     496                 :      117960 :       gfc_real_kinds[r_index].max_exponent = fmt->emax;
     497                 :      117960 :       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                 :      117960 :       gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
     507                 :      117960 :       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                 :       29490 :   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                 :       29490 :   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                 :       29490 :   gfc_numeric_storage_size = 4 * 8;
     546                 :             : 
     547                 :       29490 :   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                 :       29392 :   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                 :       29392 :   else if (saw_i4)
     565                 :             :     {
     566                 :       29392 :       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                 :       29490 :   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                 :       29488 :   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                 :       29482 :   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                 :       29476 :   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                 :       29452 :   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                 :       29428 :   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                 :       29404 :   else if (saw_r4)
     624                 :       29404 :     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                 :       29490 :   if (flag_default_double && saw_r8)
     633                 :           0 :     gfc_default_double_kind = 8;
     634                 :       29490 :   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                 :       29476 :   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                 :       29452 :   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                 :       29428 :   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                 :       29404 :   else if (saw_r4 && saw_r8)
     671                 :       29404 :     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                 :       29490 :   gfc_default_logical_kind = gfc_default_integer_kind;
     692                 :       29490 :   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                 :       29490 :   i_index = 0;
     698                 :       58980 :   if ((kind = get_int_kind_from_width (8)) > 0)
     699                 :             :     {
     700                 :       29490 :       gfc_character_kinds[i_index].kind = kind;
     701                 :       29490 :       gfc_character_kinds[i_index].bit_size = 8;
     702                 :       29490 :       gfc_character_kinds[i_index].name = "ascii";
     703                 :       29490 :       i_index++;
     704                 :             :     }
     705                 :       58980 :   if ((kind = get_int_kind_from_width (32)) > 0)
     706                 :             :     {
     707                 :       29490 :       gfc_character_kinds[i_index].kind = kind;
     708                 :       29490 :       gfc_character_kinds[i_index].bit_size = 32;
     709                 :       29490 :       gfc_character_kinds[i_index].name = "iso_10646";
     710                 :       29490 :       i_index++;
     711                 :             :     }
     712                 :             : 
     713                 :             :   /* Choose the smallest integer kind for our default character.  */
     714                 :       29490 :   gfc_default_character_kind = gfc_character_kinds[0].kind;
     715                 :       29490 :   gfc_character_storage_size = gfc_default_character_kind * 8;
     716                 :             : 
     717                 :       29897 :   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                 :       29490 :   gfc_c_int_kind = INT_TYPE_SIZE / 8;
     721                 :             : 
     722                 :             :   /* Choose atomic kinds to match C's int.  */
     723                 :       29490 :   gfc_atomic_int_kind = gfc_c_int_kind;
     724                 :       29490 :   gfc_atomic_logical_kind = gfc_c_int_kind;
     725                 :             : 
     726                 :       29490 :   gfc_c_intptr_kind = POINTER_SIZE / 8;
     727                 :       29490 : }
     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                 :    74273916 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
     739                 :    74271861 :     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                 :     4774284 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     751                 :     4774274 :     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                 :     1407599 :   for (i = 0; gfc_logical_kinds[i].kind; i++)
     763                 :     1407591 :     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                 :     1303901 :   for (i = 0; gfc_character_kinds[i].kind; i++)
     775                 :     1303887 :     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                 :    28003421 : gfc_validate_kind (bt type, int kind, bool may_fail)
     787                 :             : {
     788                 :    28003421 :   int rc;
     789                 :             : 
     790                 :    28003421 :   switch (type)
     791                 :             :     {
     792                 :             :     case BT_REAL:               /* Fall through */
     793                 :             :     case BT_COMPLEX:
     794                 :    28003421 :       rc = validate_real (kind);
     795                 :             :       break;
     796                 :             :     case BT_INTEGER:
     797                 :    28003421 :       rc = validate_integer (kind);
     798                 :             :       break;
     799                 :             :     case BT_LOGICAL:
     800                 :    28003421 :       rc = validate_logical (kind);
     801                 :             :       break;
     802                 :             :     case BT_CHARACTER:
     803                 :    28003421 :       rc = validate_character (kind);
     804                 :             :       break;
     805                 :             : 
     806                 :           0 :     default:
     807                 :           0 :       gfc_internal_error ("gfc_validate_kind(): Got bad type");
     808                 :             :     }
     809                 :             : 
     810                 :    28003421 :   if (rc < 0 && !may_fail)
     811                 :           0 :     gfc_internal_error ("gfc_validate_kind(): Got bad kind");
     812                 :             : 
     813                 :    28003421 :   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                 :      147043 : gfc_build_int_type (gfc_integer_info *info)
     824                 :             : {
     825                 :      147043 :   int mode_precision = info->bit_size;
     826                 :             : 
     827                 :      147043 :   if (mode_precision == CHAR_TYPE_SIZE)
     828                 :       29490 :     info->c_char = 1;
     829                 :      147043 :   if (mode_precision == SHORT_TYPE_SIZE)
     830                 :       29490 :     info->c_short = 1;
     831                 :      147043 :   if (mode_precision == INT_TYPE_SIZE)
     832                 :       29490 :     info->c_int = 1;
     833                 :      148671 :   if (mode_precision == LONG_TYPE_SIZE)
     834                 :       29490 :     info->c_long = 1;
     835                 :      147043 :   if (mode_precision == LONG_LONG_TYPE_SIZE)
     836                 :       29490 :     info->c_long_long = 1;
     837                 :             : 
     838                 :      147043 :   if (TYPE_PRECISION (intQI_type_node) == mode_precision)
     839                 :             :     return intQI_type_node;
     840                 :      117553 :   if (TYPE_PRECISION (intHI_type_node) == mode_precision)
     841                 :             :     return intHI_type_node;
     842                 :       88063 :   if (TYPE_PRECISION (intSI_type_node) == mode_precision)
     843                 :             :     return intSI_type_node;
     844                 :       58573 :   if (TYPE_PRECISION (intDI_type_node) == mode_precision)
     845                 :             :     return intDI_type_node;
     846                 :       29083 :   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                 :       59726 : gfc_build_uint_type (int size)
     854                 :             : {
     855                 :       59726 :   if (size == CHAR_TYPE_SIZE)
     856                 :       29616 :     return unsigned_char_type_node;
     857                 :       30110 :   if (size == SHORT_TYPE_SIZE)
     858                 :         126 :     return short_unsigned_type_node;
     859                 :       29984 :   if (size == INT_TYPE_SIZE)
     860                 :       29724 :     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                 :      117960 : gfc_build_real_type (gfc_real_info *info)
     872                 :             : {
     873                 :      117960 :   int mode_precision = info->mode_precision;
     874                 :      117960 :   tree new_type;
     875                 :             : 
     876                 :      117960 :   if (mode_precision == FLOAT_TYPE_SIZE)
     877                 :       29490 :     info->c_float = 1;
     878                 :      117960 :   if (mode_precision == DOUBLE_TYPE_SIZE)
     879                 :       29490 :     info->c_double = 1;
     880                 :      235920 :   if (mode_precision == LONG_DOUBLE_TYPE_SIZE && !info->c_float128)
     881                 :       29490 :     info->c_long_double = 1;
     882                 :      235920 :   if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
     883                 :             :     {
     884                 :             :       /* TODO: see PR101835.  */
     885                 :       29490 :       info->c_float128 = 1;
     886                 :       29490 :       gfc_real16_is_float128 = true;
     887                 :       29490 :       if (TARGET_GLIBC_MAJOR > 2
     888                 :             :           || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26))
     889                 :             :         {
     890                 :       29490 :           info->use_iec_60559 = 1;
     891                 :       29490 :           gfc_real16_use_iec_60559 = true;
     892                 :             :         }
     893                 :             :     }
     894                 :             : 
     895                 :      117960 :   if (TYPE_PRECISION (float_type_node) == mode_precision)
     896                 :             :     return float_type_node;
     897                 :       88470 :   if (TYPE_PRECISION (double_type_node) == mode_precision)
     898                 :             :     return double_type_node;
     899                 :       58980 :   if (TYPE_PRECISION (long_double_type_node) == mode_precision)
     900                 :             :     return long_double_type_node;
     901                 :             : 
     902                 :       29490 :   new_type = make_node (REAL_TYPE);
     903                 :       29490 :   TYPE_PRECISION (new_type) = mode_precision;
     904                 :       29490 :   layout_type (new_type);
     905                 :       29490 :   return new_type;
     906                 :             : }
     907                 :             : 
     908                 :             : static tree
     909                 :      117960 : gfc_build_complex_type (tree scalar_type)
     910                 :             : {
     911                 :      117960 :   tree new_type;
     912                 :             : 
     913                 :      117960 :   if (scalar_type == NULL)
     914                 :             :     return NULL;
     915                 :      117960 :   if (scalar_type == float_type_node)
     916                 :       29490 :     return complex_float_type_node;
     917                 :       88470 :   if (scalar_type == double_type_node)
     918                 :       29490 :     return complex_double_type_node;
     919                 :       58980 :   if (scalar_type == long_double_type_node)
     920                 :       29490 :     return complex_long_double_type_node;
     921                 :             : 
     922                 :       29490 :   new_type = make_node (COMPLEX_TYPE);
     923                 :       29490 :   TREE_TYPE (new_type) = scalar_type;
     924                 :       29490 :   layout_type (new_type);
     925                 :       29490 :   return new_type;
     926                 :             : }
     927                 :             : 
     928                 :             : static tree
     929                 :      147043 : gfc_build_logical_type (gfc_logical_info *info)
     930                 :             : {
     931                 :      147043 :   int bit_size = info->bit_size;
     932                 :      147043 :   tree new_type;
     933                 :             : 
     934                 :      147043 :   if (bit_size == BOOL_TYPE_SIZE)
     935                 :             :     {
     936                 :       29490 :       info->c_bool = 1;
     937                 :       29490 :       return boolean_type_node;
     938                 :             :     }
     939                 :             : 
     940                 :      117553 :   new_type = make_unsigned_type (bit_size);
     941                 :      117553 :   TREE_SET_CODE (new_type, BOOLEAN_TYPE);
     942                 :      117553 :   TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
     943                 :      117553 :   TYPE_PRECISION (new_type) = 1;
     944                 :             : 
     945                 :      117553 :   return new_type;
     946                 :             : }
     947                 :             : 
     948                 :             : 
     949                 :             : /* Create the backend type nodes. We map them to their
     950                 :             :    equivalent C type, at least for now.  We also give
     951                 :             :    names to the types here, and we push them in the
     952                 :             :    global binding level context.*/
     953                 :             : 
     954                 :             : void
     955                 :       29490 : gfc_init_types (void)
     956                 :             : {
     957                 :       29490 :   char name_buf[26];
     958                 :       29490 :   int index;
     959                 :       29490 :   tree type;
     960                 :       29490 :   unsigned n;
     961                 :             : 
     962                 :             :   /* Create and name the types.  */
     963                 :             : #define PUSH_TYPE(name, node) \
     964                 :             :   pushdecl (build_decl (input_location, \
     965                 :             :                         TYPE_DECL, get_identifier (name), node))
     966                 :             : 
     967                 :      176533 :   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
     968                 :             :     {
     969                 :      147043 :       type = gfc_build_int_type (&gfc_integer_kinds[index]);
     970                 :             :       /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
     971                 :      147043 :       if (TYPE_STRING_FLAG (type))
     972                 :       29490 :         type = make_signed_type (gfc_integer_kinds[index].bit_size);
     973                 :      147043 :       gfc_integer_types[index] = type;
     974                 :      147043 :       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
     975                 :             :                 gfc_integer_kinds[index].kind);
     976                 :      147043 :       PUSH_TYPE (name_buf, type);
     977                 :             :     }
     978                 :             : 
     979                 :      176533 :   for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
     980                 :             :     {
     981                 :      147043 :       type = gfc_build_logical_type (&gfc_logical_kinds[index]);
     982                 :      147043 :       gfc_logical_types[index] = type;
     983                 :      147043 :       snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
     984                 :             :                 gfc_logical_kinds[index].kind);
     985                 :      147043 :       PUSH_TYPE (name_buf, type);
     986                 :             :     }
     987                 :             : 
     988                 :      147450 :   for (index = 0; gfc_real_kinds[index].kind != 0; index++)
     989                 :             :     {
     990                 :      117960 :       type = gfc_build_real_type (&gfc_real_kinds[index]);
     991                 :      117960 :       gfc_real_types[index] = type;
     992                 :      117960 :       snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
     993                 :             :                 gfc_real_kinds[index].kind);
     994                 :      117960 :       PUSH_TYPE (name_buf, type);
     995                 :             : 
     996                 :      117960 :       if (gfc_real_kinds[index].c_float128)
     997                 :       29490 :         gfc_float128_type_node = type;
     998                 :             : 
     999                 :      117960 :       type = gfc_build_complex_type (type);
    1000                 :      117960 :       gfc_complex_types[index] = type;
    1001                 :      117960 :       snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
    1002                 :             :                 gfc_real_kinds[index].kind);
    1003                 :      117960 :       PUSH_TYPE (name_buf, type);
    1004                 :             : 
    1005                 :      117960 :       if (gfc_real_kinds[index].c_float128)
    1006                 :       29490 :         gfc_complex_float128_type_node = type;
    1007                 :             :     }
    1008                 :             : 
    1009                 :       88470 :   for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
    1010                 :             :     {
    1011                 :       58980 :       type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
    1012                 :       58980 :       type = build_qualified_type (type, TYPE_UNQUALIFIED);
    1013                 :       58980 :       snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
    1014                 :             :                 gfc_character_kinds[index].kind);
    1015                 :       58980 :       PUSH_TYPE (name_buf, type);
    1016                 :       58980 :       gfc_character_types[index] = type;
    1017                 :       58980 :       gfc_pcharacter_types[index] = build_pointer_type (type);
    1018                 :             :     }
    1019                 :       29490 :   gfc_character1_type_node = gfc_character_types[0];
    1020                 :             : 
    1021                 :       29490 :   PUSH_TYPE ("byte", unsigned_char_type_node);
    1022                 :       29490 :   PUSH_TYPE ("void", void_type_node);
    1023                 :             : 
    1024                 :             :   /* DBX debugging output gets upset if these aren't set.  */
    1025                 :       29490 :   if (!TYPE_NAME (integer_type_node))
    1026                 :           0 :     PUSH_TYPE ("c_integer", integer_type_node);
    1027                 :       29490 :   if (!TYPE_NAME (char_type_node))
    1028                 :       29490 :     PUSH_TYPE ("c_char", char_type_node);
    1029                 :             : 
    1030                 :             : #undef PUSH_TYPE
    1031                 :             : 
    1032                 :       29490 :   pvoid_type_node = build_pointer_type (void_type_node);
    1033                 :       29490 :   prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
    1034                 :       29490 :   ppvoid_type_node = build_pointer_type (pvoid_type_node);
    1035                 :       29490 :   pchar_type_node = build_pointer_type (gfc_character1_type_node);
    1036                 :       29490 :   pfunc_type_node
    1037                 :       29490 :     = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
    1038                 :             : 
    1039                 :       29490 :   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
    1040                 :             :   /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
    1041                 :             :      since this function is called before gfc_init_constants.  */
    1042                 :       29490 :   gfc_array_range_type
    1043                 :       29490 :           = build_range_type (gfc_array_index_type,
    1044                 :       29490 :                               build_int_cst (gfc_array_index_type, 0),
    1045                 :             :                               NULL_TREE);
    1046                 :             : 
    1047                 :             :   /* The maximum array element size that can be handled is determined
    1048                 :             :      by the number of bits available to store this field in the array
    1049                 :             :      descriptor.  */
    1050                 :             : 
    1051                 :       29490 :   n = TYPE_PRECISION (size_type_node);
    1052                 :       29490 :   gfc_max_array_element_size
    1053                 :       29490 :     = wide_int_to_tree (size_type_node,
    1054                 :       29490 :                         wi::mask (n, UNSIGNED,
    1055                 :       29490 :                                   TYPE_PRECISION (size_type_node)));
    1056                 :             : 
    1057                 :       29490 :   logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
    1058                 :       29490 :   logical_true_node = build_int_cst (logical_type_node, 1);
    1059                 :       29490 :   logical_false_node = build_int_cst (logical_type_node, 0);
    1060                 :             : 
    1061                 :             :   /* Character lengths are of type size_t, except signed.  */
    1062                 :       29490 :   gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
    1063                 :       29490 :   gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
    1064                 :             : 
    1065                 :             :   /* Fortran kind number of size_type_node (size_t). This is used for
    1066                 :             :      the _size member in vtables.  */
    1067                 :       29490 :   gfc_size_kind = get_int_kind_from_node (size_type_node);
    1068                 :       29490 : }
    1069                 :             : 
    1070                 :             : /* Get the type node for the given type and kind.  */
    1071                 :             : 
    1072                 :             : tree
    1073                 :     4777075 : gfc_get_int_type (int kind)
    1074                 :             : {
    1075                 :     4777075 :   int index = gfc_validate_kind (BT_INTEGER, kind, true);
    1076                 :     4777075 :   return index < 0 ? 0 : gfc_integer_types[index];
    1077                 :             : }
    1078                 :             : 
    1079                 :             : tree
    1080                 :      681314 : gfc_get_real_type (int kind)
    1081                 :             : {
    1082                 :      681314 :   int index = gfc_validate_kind (BT_REAL, kind, true);
    1083                 :      681314 :   return index < 0 ? 0 : gfc_real_types[index];
    1084                 :             : }
    1085                 :             : 
    1086                 :             : tree
    1087                 :      438017 : gfc_get_complex_type (int kind)
    1088                 :             : {
    1089                 :      438017 :   int index = gfc_validate_kind (BT_COMPLEX, kind, true);
    1090                 :      438017 :   return index < 0 ? 0 : gfc_complex_types[index];
    1091                 :             : }
    1092                 :             : 
    1093                 :             : tree
    1094                 :      423617 : gfc_get_logical_type (int kind)
    1095                 :             : {
    1096                 :      423617 :   int index = gfc_validate_kind (BT_LOGICAL, kind, true);
    1097                 :      423617 :   return index < 0 ? 0 : gfc_logical_types[index];
    1098                 :             : }
    1099                 :             : 
    1100                 :             : tree
    1101                 :      398710 : gfc_get_char_type (int kind)
    1102                 :             : {
    1103                 :      398710 :   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
    1104                 :      398710 :   return index < 0 ? 0 : gfc_character_types[index];
    1105                 :             : }
    1106                 :             : 
    1107                 :             : tree
    1108                 :      153600 : gfc_get_pchar_type (int kind)
    1109                 :             : {
    1110                 :      153600 :   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
    1111                 :      153600 :   return index < 0 ? 0 : gfc_pcharacter_types[index];
    1112                 :             : }
    1113                 :             : 
    1114                 :             : 
    1115                 :             : /* Create a character type with the given kind and length.  */
    1116                 :             : 
    1117                 :             : tree
    1118                 :       83708 : gfc_get_character_type_len_for_eltype (tree eltype, tree len)
    1119                 :             : {
    1120                 :       83708 :   tree bounds, type;
    1121                 :             : 
    1122                 :       83708 :   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
    1123                 :       83708 :   type = build_array_type (eltype, bounds);
    1124                 :       83708 :   TYPE_STRING_FLAG (type) = 1;
    1125                 :             : 
    1126                 :       83708 :   return type;
    1127                 :             : }
    1128                 :             : 
    1129                 :             : tree
    1130                 :       76667 : gfc_get_character_type_len (int kind, tree len)
    1131                 :             : {
    1132                 :       76667 :   gfc_validate_kind (BT_CHARACTER, kind, false);
    1133                 :       76667 :   return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
    1134                 :             : }
    1135                 :             : 
    1136                 :             : 
    1137                 :             : /* Get a type node for a character kind.  */
    1138                 :             : 
    1139                 :             : tree
    1140                 :       67065 : gfc_get_character_type (int kind, gfc_charlen * cl)
    1141                 :             : {
    1142                 :       67065 :   tree len;
    1143                 :             : 
    1144                 :       67065 :   len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
    1145                 :       66008 :   if (len && POINTER_TYPE_P (TREE_TYPE (len)))
    1146                 :           0 :     len = build_fold_indirect_ref (len);
    1147                 :             : 
    1148                 :       67065 :   return gfc_get_character_type_len (kind, len);
    1149                 :             : }
    1150                 :             : 
    1151                 :             : /* Convert a basic type.  This will be an array for character types.  */
    1152                 :             : 
    1153                 :             : tree
    1154                 :     1018249 : gfc_typenode_for_spec (gfc_typespec * spec, int codim)
    1155                 :             : {
    1156                 :     1018249 :   tree basetype;
    1157                 :             : 
    1158                 :     1018249 :   switch (spec->type)
    1159                 :             :     {
    1160                 :           0 :     case BT_UNKNOWN:
    1161                 :           0 :       gcc_unreachable ();
    1162                 :             : 
    1163                 :      379921 :     case BT_INTEGER:
    1164                 :             :       /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
    1165                 :             :          has been resolved.  This is done so we can convert C_PTR and
    1166                 :             :          C_FUNPTR to simple variables that get translated to (void *).  */
    1167                 :      379921 :       if (spec->f90_type == BT_VOID)
    1168                 :             :         {
    1169                 :         342 :           if (spec->u.derived
    1170                 :         342 :               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
    1171                 :         261 :             basetype = ptr_type_node;
    1172                 :             :           else
    1173                 :          81 :             basetype = pfunc_type_node;
    1174                 :             :         }
    1175                 :             :       else
    1176                 :      379579 :         basetype = gfc_get_int_type (spec->kind);
    1177                 :             :       break;
    1178                 :             : 
    1179                 :      124360 :     case BT_REAL:
    1180                 :      124360 :       basetype = gfc_get_real_type (spec->kind);
    1181                 :      124360 :       break;
    1182                 :             : 
    1183                 :       24774 :     case BT_COMPLEX:
    1184                 :       24774 :       basetype = gfc_get_complex_type (spec->kind);
    1185                 :       24774 :       break;
    1186                 :             : 
    1187                 :      298387 :     case BT_LOGICAL:
    1188                 :      298387 :       basetype = gfc_get_logical_type (spec->kind);
    1189                 :      298387 :       break;
    1190                 :             : 
    1191                 :       56179 :     case BT_CHARACTER:
    1192                 :       56179 :       basetype = gfc_get_character_type (spec->kind, spec->u.cl);
    1193                 :       56179 :       break;
    1194                 :             : 
    1195                 :          12 :     case BT_HOLLERITH:
    1196                 :             :       /* Since this cannot be used, return a length one character.  */
    1197                 :          12 :       basetype = gfc_get_character_type_len (gfc_default_character_kind,
    1198                 :             :                                              gfc_index_one_node);
    1199                 :          12 :       break;
    1200                 :             : 
    1201                 :         116 :     case BT_UNION:
    1202                 :         116 :       basetype = gfc_get_union_type (spec->u.derived);
    1203                 :         116 :       break;
    1204                 :             : 
    1205                 :      131867 :     case BT_DERIVED:
    1206                 :      131867 :     case BT_CLASS:
    1207                 :      131867 :       basetype = gfc_get_derived_type (spec->u.derived, codim);
    1208                 :             : 
    1209                 :      131867 :       if (spec->type == BT_CLASS)
    1210                 :       26046 :         GFC_CLASS_TYPE_P (basetype) = 1;
    1211                 :             : 
    1212                 :             :       /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
    1213                 :             :          type and kind to fit a (void *) and the basetype returned was a
    1214                 :             :          ptr_type_node.  We need to pass up this new information to the
    1215                 :             :          symbol that was declared of type C_PTR or C_FUNPTR.  */
    1216                 :      131867 :       if (spec->u.derived->ts.f90_type == BT_VOID)
    1217                 :             :         {
    1218                 :       10902 :           spec->type = BT_INTEGER;
    1219                 :       10902 :           spec->kind = gfc_index_integer_kind;
    1220                 :       10902 :           spec->f90_type = BT_VOID;
    1221                 :       10902 :           spec->is_c_interop = 1;  /* Mark as escaping later.  */
    1222                 :             :         }
    1223                 :             :       break;
    1224                 :        2614 :     case BT_VOID:
    1225                 :        2614 :     case BT_ASSUMED:
    1226                 :             :       /* This is for the second arg to c_f_pointer and c_f_procpointer
    1227                 :             :          of the iso_c_binding module, to accept any ptr type.  */
    1228                 :        2614 :       basetype = ptr_type_node;
    1229                 :        2614 :       if (spec->f90_type == BT_VOID)
    1230                 :             :         {
    1231                 :         336 :           if (spec->u.derived
    1232                 :           0 :               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
    1233                 :             :             basetype = ptr_type_node;
    1234                 :             :           else
    1235                 :         336 :             basetype = pfunc_type_node;
    1236                 :             :         }
    1237                 :             :        break;
    1238                 :          19 :     case BT_PROCEDURE:
    1239                 :          19 :       basetype = pfunc_type_node;
    1240                 :          19 :       break;
    1241                 :           0 :     default:
    1242                 :           0 :       gcc_unreachable ();
    1243                 :             :     }
    1244                 :     1018249 :   return basetype;
    1245                 :             : }
    1246                 :             : 
    1247                 :             : /* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
    1248                 :             : 
    1249                 :             : static tree
    1250                 :       84199 : gfc_conv_array_bound (gfc_expr * expr)
    1251                 :             : {
    1252                 :             :   /* If expr is an integer constant, return that.  */
    1253                 :       84199 :   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
    1254                 :       11528 :     return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
    1255                 :             : 
    1256                 :             :   /* Otherwise return NULL.  */
    1257                 :             :   return NULL_TREE;
    1258                 :             : }
    1259                 :             : 
    1260                 :             : /* Return the type of an element of the array.  Note that scalar coarrays
    1261                 :             :    are special.  In particular, for GFC_ARRAY_TYPE_P, the original argument
    1262                 :             :    (with POINTER_TYPE stripped) is returned.  */
    1263                 :             : 
    1264                 :             : tree
    1265                 :      272646 : gfc_get_element_type (tree type)
    1266                 :             : {
    1267                 :      272646 :   tree element;
    1268                 :             : 
    1269                 :      272646 :   if (GFC_ARRAY_TYPE_P (type))
    1270                 :             :     {
    1271                 :      104601 :       if (TREE_CODE (type) == POINTER_TYPE)
    1272                 :       18951 :         type = TREE_TYPE (type);
    1273                 :      104601 :       if (GFC_TYPE_ARRAY_RANK (type) == 0)
    1274                 :             :         {
    1275                 :         287 :           gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
    1276                 :             :           element = type;
    1277                 :             :         }
    1278                 :             :       else
    1279                 :             :         {
    1280                 :      104314 :           gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
    1281                 :      104314 :           element = TREE_TYPE (type);
    1282                 :             :         }
    1283                 :             :     }
    1284                 :             :   else
    1285                 :             :     {
    1286                 :      168045 :       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
    1287                 :      168045 :       element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
    1288                 :             : 
    1289                 :      168045 :       gcc_assert (TREE_CODE (element) == POINTER_TYPE);
    1290                 :      168045 :       element = TREE_TYPE (element);
    1291                 :             : 
    1292                 :             :       /* For arrays, which are not scalar coarrays.  */
    1293                 :      168045 :       if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
    1294                 :      166879 :         element = TREE_TYPE (element);
    1295                 :             :     }
    1296                 :             : 
    1297                 :      272646 :   return element;
    1298                 :             : }
    1299                 :             : 
    1300                 :             : /* Build an array.  This function is called from gfc_sym_type().
    1301                 :             :    Actually returns array descriptor type.
    1302                 :             : 
    1303                 :             :    Format of array descriptors is as follows:
    1304                 :             : 
    1305                 :             :     struct gfc_array_descriptor
    1306                 :             :     {
    1307                 :             :       array *data;
    1308                 :             :       index offset;
    1309                 :             :       struct dtype_type dtype;
    1310                 :             :       struct descriptor_dimension dimension[N_DIM];
    1311                 :             :     }
    1312                 :             : 
    1313                 :             :     struct dtype_type
    1314                 :             :     {
    1315                 :             :       size_t elem_len;
    1316                 :             :       int version;
    1317                 :             :       signed char rank;
    1318                 :             :       signed char type;
    1319                 :             :       signed short attribute;
    1320                 :             :     }
    1321                 :             : 
    1322                 :             :     struct descriptor_dimension
    1323                 :             :     {
    1324                 :             :       index stride;
    1325                 :             :       index lbound;
    1326                 :             :       index ubound;
    1327                 :             :     }
    1328                 :             : 
    1329                 :             :    Translation code should use gfc_conv_descriptor_* rather than
    1330                 :             :    accessing the descriptor directly.  Any changes to the array
    1331                 :             :    descriptor type will require changes in gfc_conv_descriptor_* and
    1332                 :             :    gfc_build_array_initializer.
    1333                 :             : 
    1334                 :             :    This is represented internally as a RECORD_TYPE. The index nodes
    1335                 :             :    are gfc_array_index_type and the data node is a pointer to the
    1336                 :             :    data.  See below for the handling of character types.
    1337                 :             : 
    1338                 :             :    I originally used nested ARRAY_TYPE nodes to represent arrays, but
    1339                 :             :    this generated poor code for assumed/deferred size arrays.  These
    1340                 :             :    require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
    1341                 :             :    of the GENERIC grammar.  Also, there is no way to explicitly set
    1342                 :             :    the array stride, so all data must be packed(1).  I've tried to
    1343                 :             :    mark all the functions which would require modification with a GCC
    1344                 :             :    ARRAYS comment.
    1345                 :             : 
    1346                 :             :    The data component points to the first element in the array.  The
    1347                 :             :    offset field is the position of the origin of the array (i.e. element
    1348                 :             :    (0, 0 ...)).  This may be outside the bounds of the array.
    1349                 :             : 
    1350                 :             :    An element is accessed by
    1351                 :             :     data[offset + index0*stride0 + index1*stride1 + index2*stride2]
    1352                 :             :    This gives good performance as the computation does not involve the
    1353                 :             :    bounds of the array.  For packed arrays, this is optimized further
    1354                 :             :    by substituting the known strides.
    1355                 :             : 
    1356                 :             :    This system has one problem: all array bounds must be within 2^31
    1357                 :             :    elements of the origin (2^63 on 64-bit machines).  For example
    1358                 :             :     integer, dimension (80000:90000, 80000:90000, 2) :: array
    1359                 :             :    may not work properly on 32-bit machines because 80000*80000 >
    1360                 :             :    2^31, so the calculation for stride2 would overflow.  This may
    1361                 :             :    still work, but I haven't checked, and it relies on the overflow
    1362                 :             :    doing the right thing.
    1363                 :             : 
    1364                 :             :    The way to fix this problem is to access elements as follows:
    1365                 :             :     data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
    1366                 :             :    Obviously this is much slower.  I will make this a compile time
    1367                 :             :    option, something like -fsmall-array-offsets.  Mixing code compiled
    1368                 :             :    with and without this switch will work.
    1369                 :             : 
    1370                 :             :    (1) This can be worked around by modifying the upper bound of the
    1371                 :             :    previous dimension.  This requires extra fields in the descriptor
    1372                 :             :    (both real_ubound and fake_ubound).  */
    1373                 :             : 
    1374                 :             : 
    1375                 :             : /* Returns true if the array sym does not require a descriptor.  */
    1376                 :             : 
    1377                 :             : bool
    1378                 :       90272 : gfc_is_nodesc_array (gfc_symbol * sym)
    1379                 :             : {
    1380                 :       90272 :   symbol_attribute *array_attr;
    1381                 :       90272 :   gfc_array_spec *as;
    1382                 :       90272 :   bool is_classarray = IS_CLASS_ARRAY (sym);
    1383                 :             : 
    1384                 :       90272 :   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
    1385                 :       90272 :   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
    1386                 :             : 
    1387                 :       90272 :   gcc_assert (array_attr->dimension || array_attr->codimension);
    1388                 :             : 
    1389                 :             :   /* We only want local arrays.  */
    1390                 :       90272 :   if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
    1391                 :       83861 :       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
    1392                 :       83861 :       || array_attr->allocatable)
    1393                 :             :     return 0;
    1394                 :             : 
    1395                 :             :   /* We want a descriptor for associate-name arrays that do not have an
    1396                 :             :          explicitly known shape already.  */
    1397                 :       76301 :   if (sym->assoc && as->type != AS_EXPLICIT)
    1398                 :             :     return 0;
    1399                 :             : 
    1400                 :             :   /* The dummy is stored in sym and not in the component.  */
    1401                 :       74690 :   if (sym->attr.dummy)
    1402                 :       33217 :     return as->type != AS_ASSUMED_SHAPE
    1403                 :       49257 :         && as->type != AS_ASSUMED_RANK;
    1404                 :             : 
    1405                 :       41473 :   if (sym->attr.result || sym->attr.function)
    1406                 :             :     return 0;
    1407                 :             : 
    1408                 :       33629 :   gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
    1409                 :             : 
    1410                 :             :   return 1;
    1411                 :             : }
    1412                 :             : 
    1413                 :             : 
    1414                 :             : /* Create an array descriptor type.  */
    1415                 :             : 
    1416                 :             : static tree
    1417                 :       39859 : gfc_build_array_type (tree type, gfc_array_spec * as,
    1418                 :             :                       enum gfc_array_kind akind, bool restricted,
    1419                 :             :                       bool contiguous, int codim)
    1420                 :             : {
    1421                 :       39859 :   tree lbound[GFC_MAX_DIMENSIONS];
    1422                 :       39859 :   tree ubound[GFC_MAX_DIMENSIONS];
    1423                 :       39859 :   int n, corank;
    1424                 :             : 
    1425                 :             :   /* Assumed-shape arrays do not have codimension information stored in the
    1426                 :             :      descriptor.  */
    1427                 :       39859 :   corank = MAX (as->corank, codim);
    1428                 :       39859 :   if (as->type == AS_ASSUMED_SHAPE ||
    1429                 :        6516 :       (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
    1430                 :       39859 :     corank = codim;
    1431                 :             : 
    1432                 :       39859 :   if (as->type == AS_ASSUMED_RANK)
    1433                 :      104256 :     for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
    1434                 :             :       {
    1435                 :       97740 :         lbound[n] = NULL_TREE;
    1436                 :       97740 :         ubound[n] = NULL_TREE;
    1437                 :             :       }
    1438                 :             : 
    1439                 :       87163 :   for (n = 0; n < as->rank; n++)
    1440                 :             :     {
    1441                 :             :       /* Create expressions for the known bounds of the array.  */
    1442                 :       47304 :       if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
    1443                 :       11384 :         lbound[n] = gfc_index_one_node;
    1444                 :             :       else
    1445                 :       35920 :         lbound[n] = gfc_conv_array_bound (as->lower[n]);
    1446                 :       47304 :       ubound[n] = gfc_conv_array_bound (as->upper[n]);
    1447                 :             :     }
    1448                 :             : 
    1449                 :       40691 :   for (n = as->rank; n < as->rank + corank; n++)
    1450                 :             :     {
    1451                 :         832 :       if (as->type != AS_DEFERRED && as->lower[n] == NULL)
    1452                 :           0 :         lbound[n] = gfc_index_one_node;
    1453                 :             :       else
    1454                 :         832 :         lbound[n] = gfc_conv_array_bound (as->lower[n]);
    1455                 :             : 
    1456                 :         832 :       if (n < as->rank + corank - 1)
    1457                 :         143 :         ubound[n] = gfc_conv_array_bound (as->upper[n]);
    1458                 :             :     }
    1459                 :             : 
    1460                 :       39859 :   if (as->type == AS_ASSUMED_SHAPE)
    1461                 :       13239 :     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
    1462                 :             :                        : GFC_ARRAY_ASSUMED_SHAPE;
    1463                 :       26620 :   else if (as->type == AS_ASSUMED_RANK)
    1464                 :        6516 :     akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
    1465                 :             :                        : GFC_ARRAY_ASSUMED_RANK;
    1466                 :       73202 :   return gfc_get_array_type_bounds (type, as->rank == -1
    1467                 :             :                                           ? GFC_MAX_DIMENSIONS : as->rank,
    1468                 :             :                                     corank, lbound, ubound, 0, akind,
    1469                 :       39859 :                                     restricted);
    1470                 :             : }
    1471                 :             : 
    1472                 :             : /* Returns the struct descriptor_dimension type.  */
    1473                 :             : 
    1474                 :             : static tree
    1475                 :       27253 : gfc_get_desc_dim_type (void)
    1476                 :             : {
    1477                 :       27253 :   tree type;
    1478                 :       27253 :   tree decl, *chain = NULL;
    1479                 :             : 
    1480                 :       27253 :   if (gfc_desc_dim_type)
    1481                 :             :     return gfc_desc_dim_type;
    1482                 :             : 
    1483                 :             :   /* Build the type node.  */
    1484                 :       10730 :   type = make_node (RECORD_TYPE);
    1485                 :             : 
    1486                 :       10730 :   TYPE_NAME (type) = get_identifier ("descriptor_dimension");
    1487                 :       10730 :   TYPE_PACKED (type) = 1;
    1488                 :             : 
    1489                 :             :   /* Consists of the stride, lbound and ubound members.  */
    1490                 :       10730 :   decl = gfc_add_field_to_struct_1 (type,
    1491                 :             :                                     get_identifier ("stride"),
    1492                 :             :                                     gfc_array_index_type, &chain);
    1493                 :       10730 :   suppress_warning (decl);
    1494                 :             : 
    1495                 :       10730 :   decl = gfc_add_field_to_struct_1 (type,
    1496                 :             :                                     get_identifier ("lbound"),
    1497                 :             :                                     gfc_array_index_type, &chain);
    1498                 :       10730 :   suppress_warning (decl);
    1499                 :             : 
    1500                 :       10730 :   decl = gfc_add_field_to_struct_1 (type,
    1501                 :             :                                     get_identifier ("ubound"),
    1502                 :             :                                     gfc_array_index_type, &chain);
    1503                 :       10730 :   suppress_warning (decl);
    1504                 :             : 
    1505                 :             :   /* Finish off the type.  */
    1506                 :       10730 :   gfc_finish_type (type);
    1507                 :       10730 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
    1508                 :             : 
    1509                 :       10730 :   gfc_desc_dim_type = type;
    1510                 :       10730 :   return type;
    1511                 :             : }
    1512                 :             : 
    1513                 :             : 
    1514                 :             : /* Return the DTYPE for an array.  This describes the type and type parameters
    1515                 :             :    of the array.  */
    1516                 :             : /* TODO: Only call this when the value is actually used, and make all the
    1517                 :             :    unknown cases abort.  */
    1518                 :             : 
    1519                 :             : tree
    1520                 :      116874 : gfc_get_dtype_rank_type (int rank, tree etype)
    1521                 :             : {
    1522                 :      116874 :   tree ptype;
    1523                 :      116874 :   tree size;
    1524                 :      116874 :   int n;
    1525                 :      116874 :   tree tmp;
    1526                 :      116874 :   tree dtype;
    1527                 :      116874 :   tree field;
    1528                 :      116874 :   vec<constructor_elt, va_gc> *v = NULL;
    1529                 :             : 
    1530                 :      116874 :   ptype = etype;
    1531                 :      116874 :   while (TREE_CODE (etype) == POINTER_TYPE
    1532                 :      143453 :          || TREE_CODE (etype) == ARRAY_TYPE)
    1533                 :             :     {
    1534                 :       26579 :       ptype = etype;
    1535                 :       26579 :       etype = TREE_TYPE (etype);
    1536                 :             :     }
    1537                 :             : 
    1538                 :      116874 :   gcc_assert (etype);
    1539                 :             : 
    1540                 :      116874 :   switch (TREE_CODE (etype))
    1541                 :             :     {
    1542                 :       68737 :     case INTEGER_TYPE:
    1543                 :       68737 :       if (TREE_CODE (ptype) == ARRAY_TYPE
    1544                 :       68737 :           && TYPE_STRING_FLAG (ptype))
    1545                 :             :         n = BT_CHARACTER;
    1546                 :             :       else
    1547                 :             :         n = BT_INTEGER;
    1548                 :             :       break;
    1549                 :             : 
    1550                 :             :     case BOOLEAN_TYPE:
    1551                 :             :       n = BT_LOGICAL;
    1552                 :             :       break;
    1553                 :             : 
    1554                 :             :     case REAL_TYPE:
    1555                 :             :       n = BT_REAL;
    1556                 :             :       break;
    1557                 :             : 
    1558                 :             :     case COMPLEX_TYPE:
    1559                 :             :       n = BT_COMPLEX;
    1560                 :             :       break;
    1561                 :             : 
    1562                 :       17117 :     case RECORD_TYPE:
    1563                 :       17117 :       if (GFC_CLASS_TYPE_P (etype))
    1564                 :             :         n = BT_CLASS;
    1565                 :             :       else
    1566                 :             :         n = BT_DERIVED;
    1567                 :             :       break;
    1568                 :             : 
    1569                 :        1582 :     case FUNCTION_TYPE:
    1570                 :        1582 :     case VOID_TYPE:
    1571                 :        1582 :       n = BT_VOID;
    1572                 :        1582 :       break;
    1573                 :             : 
    1574                 :           0 :     default:
    1575                 :             :       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
    1576                 :             :       /* We can encounter strange array types for temporary arrays.  */
    1577                 :           0 :       gcc_unreachable ();
    1578                 :             :     }
    1579                 :             : 
    1580                 :       22805 :   switch (n)
    1581                 :             :     {
    1582                 :       21223 :     case BT_CHARACTER:
    1583                 :       21223 :       gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE);
    1584                 :       21223 :       size = gfc_get_character_len_in_bytes (ptype);
    1585                 :       21223 :       break;
    1586                 :        1582 :     case BT_VOID:
    1587                 :        1582 :       gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
    1588                 :        1582 :       size = size_in_bytes (ptype);
    1589                 :        1582 :       break;
    1590                 :       94069 :     default:
    1591                 :       94069 :       size = size_in_bytes (etype);
    1592                 :       94069 :       break;
    1593                 :             :     }
    1594                 :             :       
    1595                 :      116874 :   gcc_assert (size);
    1596                 :             : 
    1597                 :      116874 :   STRIP_NOPS (size);
    1598                 :      116874 :   size = fold_convert (size_type_node, size);
    1599                 :      116874 :   tmp = get_dtype_type_node ();
    1600                 :      116874 :   field = gfc_advance_chain (TYPE_FIELDS (tmp),
    1601                 :             :                              GFC_DTYPE_ELEM_LEN);
    1602                 :      116874 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1603                 :             :                           fold_convert (TREE_TYPE (field), size));
    1604                 :      116874 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1605                 :             :                              GFC_DTYPE_VERSION);
    1606                 :      116874 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1607                 :             :                           build_zero_cst (TREE_TYPE (field)));
    1608                 :             : 
    1609                 :      116874 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1610                 :             :                              GFC_DTYPE_RANK);
    1611                 :      116874 :   if (rank >= 0)
    1612                 :      116287 :     CONSTRUCTOR_APPEND_ELT (v, field,
    1613                 :             :                             build_int_cst (TREE_TYPE (field), rank));
    1614                 :             : 
    1615                 :      116874 :   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
    1616                 :             :                              GFC_DTYPE_TYPE);
    1617                 :      116874 :   CONSTRUCTOR_APPEND_ELT (v, field,
    1618                 :             :                           build_int_cst (TREE_TYPE (field), n));
    1619                 :             : 
    1620                 :      116874 :   dtype = build_constructor (tmp, v);
    1621                 :             : 
    1622                 :      116874 :   return dtype;
    1623                 :             : }
    1624                 :             : 
    1625                 :             : 
    1626                 :             : tree
    1627                 :       95391 : gfc_get_dtype (tree type, int * rank)
    1628                 :             : {
    1629                 :       95391 :   tree dtype;
    1630                 :       95391 :   tree etype;
    1631                 :       95391 :   int irnk;
    1632                 :             : 
    1633                 :       95391 :   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
    1634                 :             : 
    1635                 :       95391 :   irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type));
    1636                 :       95391 :   etype = gfc_get_element_type (type);
    1637                 :       95391 :   dtype = gfc_get_dtype_rank_type (irnk, etype);
    1638                 :             : 
    1639                 :       95391 :   GFC_TYPE_ARRAY_DTYPE (type) = dtype;
    1640                 :       95391 :   return dtype;
    1641                 :             : }
    1642                 :             : 
    1643                 :             : 
    1644                 :             : /* Build an array type for use without a descriptor, packed according
    1645                 :             :    to the value of PACKED.  */
    1646                 :             : 
    1647                 :             : tree
    1648                 :       91238 : gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
    1649                 :             :                            bool restricted)
    1650                 :             : {
    1651                 :       91238 :   tree range;
    1652                 :       91238 :   tree type;
    1653                 :       91238 :   tree tmp;
    1654                 :       91238 :   int n;
    1655                 :       91238 :   int known_stride;
    1656                 :       91238 :   int known_offset;
    1657                 :       91238 :   mpz_t offset;
    1658                 :       91238 :   mpz_t stride;
    1659                 :       91238 :   mpz_t delta;
    1660                 :       91238 :   gfc_expr *expr;
    1661                 :             : 
    1662                 :       91238 :   mpz_init_set_ui (offset, 0);
    1663                 :       91238 :   mpz_init_set_ui (stride, 1);
    1664                 :       91238 :   mpz_init (delta);
    1665                 :             : 
    1666                 :             :   /* We don't use build_array_type because this does not include
    1667                 :             :      lang-specific information (i.e. the bounds of the array) when checking
    1668                 :             :      for duplicates.  */
    1669                 :       91238 :   if (as->rank)
    1670                 :       90983 :     type = make_node (ARRAY_TYPE);
    1671                 :             :   else
    1672                 :         255 :     type = build_variant_type_copy (etype);
    1673                 :             : 
    1674                 :       91238 :   GFC_ARRAY_TYPE_P (type) = 1;
    1675                 :       91238 :   TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
    1676                 :             : 
    1677                 :       91238 :   known_stride = (packed != PACKED_NO);
    1678                 :       91238 :   known_offset = 1;
    1679                 :      198201 :   for (n = 0; n < as->rank; n++)
    1680                 :             :     {
    1681                 :             :       /* Fill in the stride and bound components of the type.  */
    1682                 :      106963 :       if (known_stride)
    1683                 :       95438 :         tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1684                 :             :       else
    1685                 :             :         tmp = NULL_TREE;
    1686                 :      106963 :       GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
    1687                 :             : 
    1688                 :      106963 :       expr = as->lower[n];
    1689                 :      106963 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1690                 :             :         {
    1691                 :      106171 :           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1692                 :             :                                       gfc_index_integer_kind);
    1693                 :             :         }
    1694                 :             :       else
    1695                 :             :         {
    1696                 :             :           known_stride = 0;
    1697                 :             :           tmp = NULL_TREE;
    1698                 :             :         }
    1699                 :      106963 :       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
    1700                 :             : 
    1701                 :      106963 :       if (known_stride)
    1702                 :             :         {
    1703                 :             :           /* Calculate the offset.  */
    1704                 :       94977 :           mpz_mul (delta, stride, as->lower[n]->value.integer);
    1705                 :       94977 :           mpz_sub (offset, offset, delta);
    1706                 :             :         }
    1707                 :             :       else
    1708                 :             :         known_offset = 0;
    1709                 :             : 
    1710                 :      106963 :       expr = as->upper[n];
    1711                 :      106963 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1712                 :             :         {
    1713                 :       83217 :           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1714                 :             :                                   gfc_index_integer_kind);
    1715                 :             :         }
    1716                 :             :       else
    1717                 :             :         {
    1718                 :             :           tmp = NULL_TREE;
    1719                 :             :           known_stride = 0;
    1720                 :             :         }
    1721                 :      106963 :       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    1722                 :             : 
    1723                 :      106963 :       if (known_stride)
    1724                 :             :         {
    1725                 :             :           /* Calculate the stride.  */
    1726                 :       82374 :           mpz_sub (delta, as->upper[n]->value.integer,
    1727                 :       82374 :                    as->lower[n]->value.integer);
    1728                 :       82374 :           mpz_add_ui (delta, delta, 1);
    1729                 :       82374 :           mpz_mul (stride, stride, delta);
    1730                 :             :         }
    1731                 :             : 
    1732                 :             :       /* Only the first stride is known for partial packed arrays.  */
    1733                 :      106963 :       if (packed == PACKED_NO || packed == PACKED_PARTIAL)
    1734                 :        8630 :         known_stride = 0;
    1735                 :             :     }
    1736                 :       91978 :   for (n = as->rank; n < as->rank + as->corank; n++)
    1737                 :             :     {
    1738                 :         740 :       expr = as->lower[n];
    1739                 :         740 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1740                 :         644 :         tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1741                 :             :                                     gfc_index_integer_kind);
    1742                 :             :       else
    1743                 :             :         tmp = NULL_TREE;
    1744                 :         740 :       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
    1745                 :             : 
    1746                 :         740 :       expr = as->upper[n];
    1747                 :         740 :       if (expr && expr->expr_type == EXPR_CONSTANT)
    1748                 :         142 :         tmp = gfc_conv_mpz_to_tree (expr->value.integer,
    1749                 :             :                                     gfc_index_integer_kind);
    1750                 :             :       else
    1751                 :             :         tmp = NULL_TREE;
    1752                 :         740 :       if (n < as->rank + as->corank - 1)
    1753                 :         192 :       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    1754                 :             :     }
    1755                 :             : 
    1756                 :       91238 :   if (known_offset)
    1757                 :             :     {
    1758                 :       82150 :       GFC_TYPE_ARRAY_OFFSET (type) =
    1759                 :       82150 :         gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
    1760                 :             :     }
    1761                 :             :   else
    1762                 :        9088 :     GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
    1763                 :             : 
    1764                 :       91238 :   if (known_stride)
    1765                 :             :     {
    1766                 :       66229 :       GFC_TYPE_ARRAY_SIZE (type) =
    1767                 :       66229 :         gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1768                 :             :     }
    1769                 :             :   else
    1770                 :       25009 :     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
    1771                 :             : 
    1772                 :       91238 :   GFC_TYPE_ARRAY_RANK (type) = as->rank;
    1773                 :       91238 :   GFC_TYPE_ARRAY_CORANK (type) = as->corank;
    1774                 :       91238 :   GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
    1775                 :       91238 :   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    1776                 :             :                             NULL_TREE);
    1777                 :             :   /* TODO: use main type if it is unbounded.  */
    1778                 :       91238 :   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    1779                 :       91238 :     build_pointer_type (build_array_type (etype, range));
    1780                 :       91238 :   if (restricted)
    1781                 :       88305 :     GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    1782                 :       88305 :       build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
    1783                 :             :                             TYPE_QUAL_RESTRICT);
    1784                 :             : 
    1785                 :       91238 :   if (as->rank == 0)
    1786                 :             :     {
    1787                 :         255 :       if (packed != PACKED_STATIC  || flag_coarray == GFC_FCOARRAY_LIB)
    1788                 :             :         {
    1789                 :         204 :           type = build_pointer_type (type);
    1790                 :             : 
    1791                 :         204 :           if (restricted)
    1792                 :         204 :             type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    1793                 :             : 
    1794                 :         204 :           GFC_ARRAY_TYPE_P (type) = 1;
    1795                 :         204 :           TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    1796                 :             :         }
    1797                 :             : 
    1798                 :         255 :       goto array_type_done;
    1799                 :             :     }
    1800                 :             : 
    1801                 :       90983 :   if (known_stride)
    1802                 :             :     {
    1803                 :       65974 :       mpz_sub_ui (stride, stride, 1);
    1804                 :       65974 :       range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    1805                 :             :     }
    1806                 :             :   else
    1807                 :             :     range = NULL_TREE;
    1808                 :             : 
    1809                 :       90983 :   range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
    1810                 :       90983 :   TYPE_DOMAIN (type) = range;
    1811                 :             : 
    1812                 :       90983 :   build_pointer_type (etype);
    1813                 :       90983 :   TREE_TYPE (type) = etype;
    1814                 :             : 
    1815                 :       90983 :   layout_type (type);
    1816                 :             : 
    1817                 :             :   /* Represent packed arrays as multi-dimensional if they have rank >
    1818                 :             :      1 and with proper bounds, instead of flat arrays.  This makes for
    1819                 :             :      better debug info.  */
    1820                 :       90983 :   if (known_offset)
    1821                 :             :     {
    1822                 :       81895 :       tree gtype = etype, rtype, type_decl;
    1823                 :             : 
    1824                 :      174384 :       for (n = as->rank - 1; n >= 0; n--)
    1825                 :             :         {
    1826                 :      369956 :           rtype = build_range_type (gfc_array_index_type,
    1827                 :       92489 :                                     GFC_TYPE_ARRAY_LBOUND (type, n),
    1828                 :       92489 :                                     GFC_TYPE_ARRAY_UBOUND (type, n));
    1829                 :       92489 :           gtype = build_array_type (gtype, rtype);
    1830                 :             :         }
    1831                 :       81895 :       TYPE_NAME (type) = type_decl = build_decl (input_location,
    1832                 :             :                                                  TYPE_DECL, NULL, gtype);
    1833                 :       81895 :       DECL_ORIGINAL_TYPE (type_decl) = gtype;
    1834                 :             :     }
    1835                 :             : 
    1836                 :       90983 :   if (packed != PACKED_STATIC || !known_stride
    1837                 :       62308 :       || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
    1838                 :             :     {
    1839                 :             :       /* For dummy arrays and automatic (heap allocated) arrays we
    1840                 :             :          want a pointer to the array.  */
    1841                 :       28744 :       type = build_pointer_type (type);
    1842                 :       28744 :       if (restricted)
    1843                 :       27573 :         type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    1844                 :       28744 :       GFC_ARRAY_TYPE_P (type) = 1;
    1845                 :       28744 :       TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    1846                 :             :     }
    1847                 :             : 
    1848                 :       62239 : array_type_done:
    1849                 :       91238 :   mpz_clear (offset);
    1850                 :       91238 :   mpz_clear (stride);
    1851                 :       91238 :   mpz_clear (delta);
    1852                 :             : 
    1853                 :       91238 :   return type;
    1854                 :             : }
    1855                 :             : 
    1856                 :             : 
    1857                 :             : /* Return or create the base type for an array descriptor.  */
    1858                 :             : 
    1859                 :             : static tree
    1860                 :      244406 : gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
    1861                 :             : {
    1862                 :      244406 :   tree fat_type, decl, arraytype, *chain = NULL;
    1863                 :      244406 :   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
    1864                 :      244406 :   int idx;
    1865                 :             : 
    1866                 :             :   /* Assumed-rank array.  */
    1867                 :      244406 :   if (dimen == -1)
    1868                 :           0 :     dimen = GFC_MAX_DIMENSIONS;
    1869                 :             : 
    1870                 :      244406 :   idx = 2 * (codimen + dimen) + restricted;
    1871                 :             : 
    1872                 :      244406 :   gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
    1873                 :             : 
    1874                 :      244406 :   if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    1875                 :             :     {
    1876                 :        1020 :       if (gfc_array_descriptor_base_caf[idx])
    1877                 :             :         return gfc_array_descriptor_base_caf[idx];
    1878                 :             :     }
    1879                 :      243386 :   else if (gfc_array_descriptor_base[idx])
    1880                 :             :     return gfc_array_descriptor_base[idx];
    1881                 :             : 
    1882                 :             :   /* Build the type node.  */
    1883                 :       29771 :   fat_type = make_node (RECORD_TYPE);
    1884                 :             : 
    1885                 :       29771 :   sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
    1886                 :       29771 :   TYPE_NAME (fat_type) = get_identifier (name);
    1887                 :       29771 :   TYPE_NAMELESS (fat_type) = 1;
    1888                 :             : 
    1889                 :             :   /* Add the data member as the first element of the descriptor.  */
    1890                 :       29771 :   gfc_add_field_to_struct_1 (fat_type,
    1891                 :             :                              get_identifier ("data"),
    1892                 :             :                              (restricted
    1893                 :             :                               ? prvoid_type_node
    1894                 :             :                               : ptr_type_node), &chain);
    1895                 :             : 
    1896                 :             :   /* Add the base component.  */
    1897                 :       29771 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1898                 :             :                                     get_identifier ("offset"),
    1899                 :             :                                     gfc_array_index_type, &chain);
    1900                 :       29771 :   suppress_warning (decl);
    1901                 :             : 
    1902                 :             :   /* Add the dtype component.  */
    1903                 :       29771 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1904                 :             :                                     get_identifier ("dtype"),
    1905                 :             :                                     get_dtype_type_node (), &chain);
    1906                 :       29771 :   suppress_warning (decl);
    1907                 :             : 
    1908                 :             :   /* Add the span component.  */
    1909                 :       29771 :   decl = gfc_add_field_to_struct_1 (fat_type,
    1910                 :             :                                     get_identifier ("span"),
    1911                 :             :                                     gfc_array_index_type, &chain);
    1912                 :       29771 :   suppress_warning (decl);
    1913                 :             : 
    1914                 :             :   /* Build the array type for the stride and bound components.  */
    1915                 :       29771 :   if (dimen + codimen > 0)
    1916                 :             :     {
    1917                 :       27253 :       arraytype =
    1918                 :       27253 :         build_array_type (gfc_get_desc_dim_type (),
    1919                 :             :                           build_range_type (gfc_array_index_type,
    1920                 :             :                                             gfc_index_zero_node,
    1921                 :       27253 :                                             gfc_rank_cst[codimen + dimen - 1]));
    1922                 :             : 
    1923                 :       27253 :       decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
    1924                 :             :                                         arraytype, &chain);
    1925                 :       27253 :       suppress_warning (decl);
    1926                 :             :     }
    1927                 :             : 
    1928                 :       29771 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    1929                 :             :     {
    1930                 :        1158 :       decl = gfc_add_field_to_struct_1 (fat_type,
    1931                 :             :                                         get_identifier ("token"),
    1932                 :             :                                         prvoid_type_node, &chain);
    1933                 :        1158 :       suppress_warning (decl);
    1934                 :             :     }
    1935                 :             : 
    1936                 :             :   /* Finish off the type.  */
    1937                 :       29771 :   gfc_finish_type (fat_type);
    1938                 :       29771 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
    1939                 :             : 
    1940                 :       29771 :   if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    1941                 :         430 :     gfc_array_descriptor_base_caf[idx] = fat_type;
    1942                 :             :   else
    1943                 :       29341 :     gfc_array_descriptor_base[idx] = fat_type;
    1944                 :             : 
    1945                 :             :   return fat_type;
    1946                 :             : }
    1947                 :             : 
    1948                 :             : 
    1949                 :             : /* Build an array (descriptor) type with given bounds.  */
    1950                 :             : 
    1951                 :             : tree
    1952                 :      122203 : gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
    1953                 :             :                            tree * ubound, int packed,
    1954                 :             :                            enum gfc_array_kind akind, bool restricted)
    1955                 :             : {
    1956                 :      122203 :   char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
    1957                 :      122203 :   tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
    1958                 :      122203 :   const char *type_name;
    1959                 :      122203 :   int n;
    1960                 :             : 
    1961                 :      122203 :   base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
    1962                 :      122203 :   fat_type = build_distinct_type_copy (base_type);
    1963                 :             :   /* Unshare TYPE_FIELDs.  */
    1964                 :      730245 :   for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp))
    1965                 :             :     {
    1966                 :      608042 :       tree next = DECL_CHAIN (*tp);
    1967                 :      608042 :       *tp = copy_node (*tp);
    1968                 :      608042 :       DECL_CONTEXT (*tp) = fat_type;
    1969                 :      608042 :       DECL_CHAIN (*tp) = next;
    1970                 :             :     }
    1971                 :             :   /* Make sure that nontarget and target array type have the same canonical
    1972                 :             :      type (and same stub decl for debug info).  */
    1973                 :      122203 :   base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
    1974                 :      122203 :   TYPE_CANONICAL (fat_type) = base_type;
    1975                 :      122203 :   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
    1976                 :             :   /* Arrays of unknown type must alias with all array descriptors.  */
    1977                 :      122203 :   TYPE_TYPELESS_STORAGE (base_type) = 1;
    1978                 :      122203 :   TYPE_TYPELESS_STORAGE (fat_type) = 1;
    1979                 :      122203 :   gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type));
    1980                 :             : 
    1981                 :      122203 :   tmp = etype;
    1982                 :      122203 :   if (TREE_CODE (tmp) == ARRAY_TYPE
    1983                 :      122203 :       && TYPE_STRING_FLAG (tmp))
    1984                 :       21886 :     tmp = TREE_TYPE (etype);
    1985                 :      122203 :   tmp = TYPE_NAME (tmp);
    1986                 :      122203 :   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
    1987                 :      102402 :     tmp = DECL_NAME (tmp);
    1988                 :      102402 :   if (tmp)
    1989                 :      119593 :     type_name = IDENTIFIER_POINTER (tmp);
    1990                 :             :   else
    1991                 :             :     type_name = "unknown";
    1992                 :      122203 :   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
    1993                 :             :            GFC_MAX_SYMBOL_LEN, type_name);
    1994                 :      122203 :   TYPE_NAME (fat_type) = get_identifier (name);
    1995                 :      122203 :   TYPE_NAMELESS (fat_type) = 1;
    1996                 :             : 
    1997                 :      122203 :   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
    1998                 :      122203 :   TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
    1999                 :             : 
    2000                 :      122203 :   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
    2001                 :      122203 :   GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
    2002                 :      122203 :   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
    2003                 :      122203 :   GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
    2004                 :             : 
    2005                 :             :   /* Build an array descriptor record type.  */
    2006                 :      122203 :   if (packed != 0)
    2007                 :       30018 :     stride = gfc_index_one_node;
    2008                 :             :   else
    2009                 :             :     stride = NULL_TREE;
    2010                 :      378398 :   for (n = 0; n < dimen + codimen; n++)
    2011                 :             :     {
    2012                 :      257280 :       if (n < dimen)
    2013                 :      255531 :         GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
    2014                 :             : 
    2015                 :      257280 :       if (lbound)
    2016                 :      257280 :         lower = lbound[n];
    2017                 :             :       else
    2018                 :             :         lower = NULL_TREE;
    2019                 :             : 
    2020                 :      257280 :       if (lower != NULL_TREE)
    2021                 :             :         {
    2022                 :      133312 :           if (INTEGER_CST_P (lower))
    2023                 :      132226 :             GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
    2024                 :             :           else
    2025                 :             :             lower = NULL_TREE;
    2026                 :             :         }
    2027                 :             : 
    2028                 :      257280 :       if (codimen && n == dimen + codimen - 1)
    2029                 :             :         break;
    2030                 :             : 
    2031                 :      256195 :       upper = ubound[n];
    2032                 :      256195 :       if (upper != NULL_TREE)
    2033                 :             :         {
    2034                 :      109300 :           if (INTEGER_CST_P (upper))
    2035                 :       85009 :             GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
    2036                 :             :           else
    2037                 :             :             upper = NULL_TREE;
    2038                 :             :         }
    2039                 :             : 
    2040                 :      256195 :       if (n >= dimen)
    2041                 :         664 :         continue;
    2042                 :             : 
    2043                 :      255531 :       if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
    2044                 :             :         {
    2045                 :       23996 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2046                 :             :                                  gfc_array_index_type, upper, lower);
    2047                 :       23996 :           tmp = fold_build2_loc (input_location, PLUS_EXPR,
    2048                 :             :                                  gfc_array_index_type, tmp,
    2049                 :             :                                  gfc_index_one_node);
    2050                 :       23996 :           stride = fold_build2_loc (input_location, MULT_EXPR,
    2051                 :             :                                     gfc_array_index_type, tmp, stride);
    2052                 :             :           /* Check the folding worked.  */
    2053                 :       23996 :           gcc_assert (INTEGER_CST_P (stride));
    2054                 :             :         }
    2055                 :             :       else
    2056                 :             :         stride = NULL_TREE;
    2057                 :             :     }
    2058                 :      122203 :   GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
    2059                 :             : 
    2060                 :             :   /* TODO: known offsets for descriptors.  */
    2061                 :      122203 :   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
    2062                 :             : 
    2063                 :      122203 :   if (dimen == 0)
    2064                 :             :     {
    2065                 :        5926 :       arraytype =  build_pointer_type (etype);
    2066                 :        5926 :       if (restricted)
    2067                 :        5499 :         arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
    2068                 :             : 
    2069                 :        5926 :       GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
    2070                 :        5926 :       return fat_type;
    2071                 :             :     }
    2072                 :             : 
    2073                 :             :   /* We define data as an array with the correct size if possible.
    2074                 :             :      Much better than doing pointer arithmetic.  */
    2075                 :      116277 :   if (stride)
    2076                 :       19302 :     rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    2077                 :             :                               int_const_binop (MINUS_EXPR, stride,
    2078                 :       38604 :                                                build_int_cst (TREE_TYPE (stride), 1)));
    2079                 :             :   else
    2080                 :       96975 :     rtype = gfc_array_range_type;
    2081                 :      116277 :   arraytype = build_array_type (etype, rtype);
    2082                 :      116277 :   arraytype = build_pointer_type (arraytype);
    2083                 :      116277 :   if (restricted)
    2084                 :       54174 :     arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
    2085                 :      116277 :   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
    2086                 :             : 
    2087                 :             :   /* This will generate the base declarations we need to emit debug
    2088                 :             :      information for this type.  FIXME: there must be a better way to
    2089                 :             :      avoid divergence between compilations with and without debug
    2090                 :             :      information.  */
    2091                 :      116277 :   {
    2092                 :      116277 :     struct array_descr_info info;
    2093                 :      116277 :     gfc_get_array_descr_info (fat_type, &info);
    2094                 :      116277 :     gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
    2095                 :             :   }
    2096                 :             : 
    2097                 :      116277 :   return fat_type;
    2098                 :             : }
    2099                 :             : 
    2100                 :             : /* Build a pointer type. This function is called from gfc_sym_type().  */
    2101                 :             : 
    2102                 :             : static tree
    2103                 :       14258 : gfc_build_pointer_type (gfc_symbol * sym, tree type)
    2104                 :             : {
    2105                 :             :   /* Array pointer types aren't actually pointers.  */
    2106                 :           0 :   if (sym->attr.dimension)
    2107                 :             :     return type;
    2108                 :             :   else
    2109                 :       14258 :     return build_pointer_type (type);
    2110                 :             : }
    2111                 :             : 
    2112                 :             : static tree gfc_nonrestricted_type (tree t);
    2113                 :             : /* Given two record or union type nodes TO and FROM, ensure
    2114                 :             :    that all fields in FROM have a corresponding field in TO,
    2115                 :             :    their type being nonrestrict variants.  This accepts a TO
    2116                 :             :    node that already has a prefix of the fields in FROM.  */
    2117                 :             : static void
    2118                 :        2519 : mirror_fields (tree to, tree from)
    2119                 :             : {
    2120                 :        2519 :   tree fto, ffrom;
    2121                 :        2519 :   tree *chain;
    2122                 :             : 
    2123                 :             :   /* Forward to the end of TOs fields.  */
    2124                 :        2519 :   fto = TYPE_FIELDS (to);
    2125                 :        2519 :   ffrom = TYPE_FIELDS (from);
    2126                 :        2519 :   chain = &TYPE_FIELDS (to);
    2127                 :        2519 :   while (fto)
    2128                 :             :     {
    2129                 :           0 :       gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
    2130                 :           0 :       chain = &DECL_CHAIN (fto);
    2131                 :           0 :       fto = DECL_CHAIN (fto);
    2132                 :           0 :       ffrom = DECL_CHAIN (ffrom);
    2133                 :             :     }
    2134                 :             : 
    2135                 :             :   /* Now add all fields remaining in FROM (starting with ffrom).  */
    2136                 :       11010 :   for (; ffrom; ffrom = DECL_CHAIN (ffrom))
    2137                 :             :     {
    2138                 :        8491 :       tree newfield = copy_node (ffrom);
    2139                 :        8491 :       DECL_CONTEXT (newfield) = to;
    2140                 :             :       /* The store to DECL_CHAIN might seem redundant with the
    2141                 :             :          stores to *chain, but not clearing it here would mean
    2142                 :             :          leaving a chain into the old fields.  If ever
    2143                 :             :          our called functions would look at them confusion
    2144                 :             :          will arise.  */
    2145                 :        8491 :       DECL_CHAIN (newfield) = NULL_TREE;
    2146                 :        8491 :       *chain = newfield;
    2147                 :        8491 :       chain = &DECL_CHAIN (newfield);
    2148                 :             : 
    2149                 :        8491 :       if (TREE_CODE (ffrom) == FIELD_DECL)
    2150                 :             :         {
    2151                 :        8491 :           tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
    2152                 :        8491 :           TREE_TYPE (newfield) = elemtype;
    2153                 :             :         }
    2154                 :             :     }
    2155                 :        2519 :   *chain = NULL_TREE;
    2156                 :        2519 : }
    2157                 :             : 
    2158                 :             : /* Given a type T, returns a different type of the same structure,
    2159                 :             :    except that all types it refers to (recursively) are always
    2160                 :             :    non-restrict qualified types.  */
    2161                 :             : static tree
    2162                 :      224511 : gfc_nonrestricted_type (tree t)
    2163                 :             : {
    2164                 :      224511 :   tree ret = t;
    2165                 :             : 
    2166                 :             :   /* If the type isn't laid out yet, don't copy it.  If something
    2167                 :             :      needs it for real it should wait until the type got finished.  */
    2168                 :      224511 :   if (!TYPE_SIZE (t))
    2169                 :             :     return t;
    2170                 :             : 
    2171                 :      213608 :   if (!TYPE_LANG_SPECIFIC (t))
    2172                 :       88190 :     TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
    2173                 :             :   /* If we're dealing with this very node already further up
    2174                 :             :      the call chain (recursion via pointers and struct members)
    2175                 :             :      we haven't yet determined if we really need a new type node.
    2176                 :             :      Assume we don't, return T itself.  */
    2177                 :      213608 :   if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
    2178                 :             :     return t;
    2179                 :             : 
    2180                 :             :   /* If we have calculated this all already, just return it.  */
    2181                 :      206366 :   if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
    2182                 :      114748 :     return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
    2183                 :             : 
    2184                 :             :   /* Mark this type.  */
    2185                 :       91618 :   TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
    2186                 :             : 
    2187                 :       91618 :   switch (TREE_CODE (t))
    2188                 :             :     {
    2189                 :             :       default:
    2190                 :             :         break;
    2191                 :             : 
    2192                 :       35673 :       case POINTER_TYPE:
    2193                 :       35673 :       case REFERENCE_TYPE:
    2194                 :       35673 :         {
    2195                 :       35673 :           tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
    2196                 :       35673 :           if (totype == TREE_TYPE (t))
    2197                 :             :             ret = t;
    2198                 :        1056 :           else if (TREE_CODE (t) == POINTER_TYPE)
    2199                 :        1056 :             ret = build_pointer_type (totype);
    2200                 :             :           else
    2201                 :           0 :             ret = build_reference_type (totype);
    2202                 :       71346 :           ret = build_qualified_type (ret,
    2203                 :       35673 :                                       TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
    2204                 :             :         }
    2205                 :       35673 :         break;
    2206                 :             : 
    2207                 :        5212 :       case ARRAY_TYPE:
    2208                 :        5212 :         {
    2209                 :        5212 :           tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
    2210                 :        5212 :           if (elemtype == TREE_TYPE (t))
    2211                 :             :             ret = t;
    2212                 :             :           else
    2213                 :             :             {
    2214                 :          17 :               ret = build_variant_type_copy (t);
    2215                 :          17 :               TREE_TYPE (ret) = elemtype;
    2216                 :          17 :               if (TYPE_LANG_SPECIFIC (t)
    2217                 :          17 :                   && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
    2218                 :             :                 {
    2219                 :          17 :                   tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
    2220                 :          17 :                   dataptr_type = gfc_nonrestricted_type (dataptr_type);
    2221                 :          17 :                   if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
    2222                 :             :                     {
    2223                 :          17 :                       TYPE_LANG_SPECIFIC (ret)
    2224                 :          17 :                         = ggc_cleared_alloc<struct lang_type> ();
    2225                 :          17 :                       *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
    2226                 :          17 :                       GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
    2227                 :             :                     }
    2228                 :             :                 }
    2229                 :             :             }
    2230                 :             :         }
    2231                 :             :         break;
    2232                 :             : 
    2233                 :       24381 :       case RECORD_TYPE:
    2234                 :       24381 :       case UNION_TYPE:
    2235                 :       24381 :       case QUAL_UNION_TYPE:
    2236                 :       24381 :         {
    2237                 :       24381 :           tree field;
    2238                 :             :           /* First determine if we need a new type at all.
    2239                 :             :              Careful, the two calls to gfc_nonrestricted_type per field
    2240                 :             :              might return different values.  That happens exactly when
    2241                 :             :              one of the fields reaches back to this very record type
    2242                 :             :              (via pointers).  The first calls will assume that we don't
    2243                 :             :              need to copy T (see the error_mark_node marking).  If there
    2244                 :             :              are any reasons for copying T apart from having to copy T,
    2245                 :             :              we'll indeed copy it, and the second calls to
    2246                 :             :              gfc_nonrestricted_type will use that new node if they
    2247                 :             :              reach back to T.  */
    2248                 :      124529 :           for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
    2249                 :      102667 :             if (TREE_CODE (field) == FIELD_DECL)
    2250                 :             :               {
    2251                 :      102667 :                 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
    2252                 :      102667 :                 if (elemtype != TREE_TYPE (field))
    2253                 :             :                   break;
    2254                 :             :               }
    2255                 :       24381 :           if (!field)
    2256                 :             :             break;
    2257                 :        2519 :           ret = build_variant_type_copy (t);
    2258                 :        2519 :           TYPE_FIELDS (ret) = NULL_TREE;
    2259                 :             : 
    2260                 :             :           /* Here we make sure that as soon as we know we have to copy
    2261                 :             :              T, that also fields reaching back to us will use the new
    2262                 :             :              copy.  It's okay if that copy still contains the old fields,
    2263                 :             :              we won't look at them.  */
    2264                 :        2519 :           TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
    2265                 :        2519 :           mirror_fields (ret, t);
    2266                 :             :         }
    2267                 :        2519 :         break;
    2268                 :             :     }
    2269                 :             : 
    2270                 :       91618 :   TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
    2271                 :       91618 :   return ret;
    2272                 :             : }
    2273                 :             : 
    2274                 :             : 
    2275                 :             : /* Return the type for a symbol.  Special handling is required for character
    2276                 :             :    types to get the correct level of indirection.
    2277                 :             :    For functions return the return type.
    2278                 :             :    For subroutines return void_type_node.
    2279                 :             :    Calling this multiple times for the same symbol should be avoided,
    2280                 :             :    especially for character and array types.  */
    2281                 :             : 
    2282                 :             : tree
    2283                 :      351904 : gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
    2284                 :             : {
    2285                 :      351904 :   tree type;
    2286                 :      351904 :   int byref;
    2287                 :      351904 :   bool restricted;
    2288                 :             : 
    2289                 :             :   /* Procedure Pointers inside COMMON blocks.  */
    2290                 :      351904 :   if (sym->attr.proc_pointer && sym->attr.in_common)
    2291                 :             :     {
    2292                 :             :       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
    2293                 :          30 :       sym->attr.proc_pointer = 0;
    2294                 :          30 :       type = build_pointer_type (gfc_get_function_type (sym));
    2295                 :          30 :       sym->attr.proc_pointer = 1;
    2296                 :          30 :       return type;
    2297                 :             :     }
    2298                 :             : 
    2299                 :      351874 :   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
    2300                 :           0 :     return void_type_node;
    2301                 :             : 
    2302                 :             :   /* In the case of a function the fake result variable may have a
    2303                 :             :      type different from the function type, so don't return early in
    2304                 :             :      that case.  */
    2305                 :      351874 :   if (sym->backend_decl && !sym->attr.function)
    2306                 :         445 :     return TREE_TYPE (sym->backend_decl);
    2307                 :             : 
    2308                 :      351429 :   if (sym->attr.result
    2309                 :        5229 :       && sym->ts.type == BT_CHARACTER
    2310                 :        1027 :       && sym->ts.u.cl->backend_decl == NULL_TREE
    2311                 :         433 :       && sym->ns->proc_name
    2312                 :         427 :       && sym->ns->proc_name->ts.u.cl
    2313                 :         425 :       && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
    2314                 :           6 :     sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;
    2315                 :             : 
    2316                 :      351429 :   if (sym->ts.type == BT_CHARACTER
    2317                 :      351429 :       && ((sym->attr.function && sym->attr.is_bind_c)
    2318                 :       38339 :           || ((sym->attr.result || sym->attr.value)
    2319                 :        1443 :               && sym->ns->proc_name
    2320                 :        1437 :               && sym->ns->proc_name->attr.is_bind_c)
    2321                 :       38084 :           || (sym->ts.deferred && (!sym->ts.u.cl
    2322                 :        3208 :                                    || !sym->ts.u.cl->backend_decl))
    2323                 :       37248 :           || (sym->attr.dummy
    2324                 :       37248 :               && sym->attr.value
    2325                 :         163 :               && gfc_length_one_character_type_p (&sym->ts))))
    2326                 :        1282 :     type = gfc_get_char_type (sym->ts.kind);
    2327                 :             :   else
    2328                 :      350147 :     type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
    2329                 :             : 
    2330                 :      351429 :   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
    2331                 :      124743 :       && !sym->pass_as_value)
    2332                 :             :     byref = 1;
    2333                 :             :   else
    2334                 :      227662 :     byref = 0;
    2335                 :             : 
    2336                 :      325117 :   restricted = (!sym->attr.target && !IS_POINTER (sym)
    2337                 :      661083 :                 && !IS_PROC_POINTER (sym) && !sym->attr.cray_pointee);
    2338                 :       42450 :   if (!restricted)
    2339                 :       42450 :     type = gfc_nonrestricted_type (type);
    2340                 :             : 
    2341                 :             :   /* Dummy argument to a bind(C) procedure.  */
    2342                 :      351429 :   if (is_bind_c && is_CFI_desc (sym, NULL))
    2343                 :        3602 :     type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
    2344                 :             :                              /* restricted = */ false);
    2345                 :      347827 :   else if (sym->attr.dimension || sym->attr.codimension)
    2346                 :             :     {
    2347                 :       81010 :       if (gfc_is_nodesc_array (sym))
    2348                 :             :         {
    2349                 :             :           /* If this is a character argument of unknown length, just use the
    2350                 :             :              base type.  */
    2351                 :       45746 :           if (sym->ts.type != BT_CHARACTER
    2352                 :        5314 :               || !(sym->attr.dummy || sym->attr.function)
    2353                 :        1588 :               || sym->ts.u.cl->backend_decl)
    2354                 :             :             {
    2355                 :       45428 :               type = gfc_get_nodesc_array_type (type, sym->as,
    2356                 :             :                                                 byref ? PACKED_FULL
    2357                 :             :                                                       : PACKED_STATIC,
    2358                 :             :                                                 restricted);
    2359                 :       45428 :               byref = 0;
    2360                 :             :             }
    2361                 :             :         }
    2362                 :             :       else
    2363                 :             :         {
    2364                 :       35264 :           enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
    2365                 :       35264 :           if (sym->attr.pointer)
    2366                 :        6411 :             akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
    2367                 :             :                                          : GFC_ARRAY_POINTER;
    2368                 :       28853 :           else if (sym->attr.allocatable)
    2369                 :        7554 :             akind = GFC_ARRAY_ALLOCATABLE;
    2370                 :       35264 :           type = gfc_build_array_type (type, sym->as, akind, restricted,
    2371                 :       35264 :                                        sym->attr.contiguous, false);
    2372                 :             :         }
    2373                 :             :     }
    2374                 :             :   else
    2375                 :             :     {
    2376                 :      266817 :       if (sym->attr.allocatable || sym->attr.pointer
    2377                 :      266817 :           || gfc_is_associate_pointer (sym))
    2378                 :       14258 :         type = gfc_build_pointer_type (sym, type);
    2379                 :             :     }
    2380                 :             : 
    2381                 :             :   /* We currently pass all parameters by reference.
    2382                 :             :      See f95_get_function_decl.  For dummy function parameters return the
    2383                 :             :      function type.  */
    2384                 :      351429 :   if (byref)
    2385                 :             :     {
    2386                 :             :       /* We must use pointer types for potentially absent variables.  The
    2387                 :             :          optimizers assume a reference type argument is never NULL.  */
    2388                 :      112003 :       if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
    2389                 :      112003 :           || sym->attr.optional
    2390                 :       98664 :           || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
    2391                 :       14979 :         type = build_pointer_type (type);
    2392                 :             :       else
    2393                 :       97024 :         type = build_reference_type (type);
    2394                 :             : 
    2395                 :      112003 :       if (restricted)
    2396                 :      105624 :         type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    2397                 :             :     }
    2398                 :             : 
    2399                 :             :   return (type);
    2400                 :             : }
    2401                 :             : 
    2402                 :             : /* Layout and output debug info for a record type.  */
    2403                 :             : 
    2404                 :             : void
    2405                 :      310378 : gfc_finish_type (tree type)
    2406                 :             : {
    2407                 :      310378 :   tree decl;
    2408                 :             : 
    2409                 :      310378 :   decl = build_decl (input_location,
    2410                 :             :                      TYPE_DECL, NULL_TREE, type);
    2411                 :      310378 :   TYPE_STUB_DECL (type) = decl;
    2412                 :      310378 :   layout_type (type);
    2413                 :      310378 :   rest_of_type_compilation (type, 1);
    2414                 :      310378 :   rest_of_decl_compilation (decl, 1, 0);
    2415                 :      310378 : }
    2416                 :             : 
    2417                 :             : /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
    2418                 :             :    or RECORD_TYPE pointed to by CONTEXT.  The new field is chained
    2419                 :             :    to the end of the field list pointed to by *CHAIN.
    2420                 :             : 
    2421                 :             :    Returns a pointer to the new field.  */
    2422                 :             : 
    2423                 :             : static tree
    2424                 :     4653799 : gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
    2425                 :             : {
    2426                 :     4653799 :   tree decl = build_decl (input_location, FIELD_DECL, name, type);
    2427                 :             : 
    2428                 :     4653799 :   DECL_CONTEXT (decl) = context;
    2429                 :     4653799 :   DECL_CHAIN (decl) = NULL_TREE;
    2430                 :     4653799 :   if (TYPE_FIELDS (context) == NULL_TREE)
    2431                 :      304956 :     TYPE_FIELDS (context) = decl;
    2432                 :     4653799 :   if (chain != NULL)
    2433                 :             :     {
    2434                 :     4653799 :       if (*chain != NULL)
    2435                 :     4348843 :         **chain = decl;
    2436                 :     4653799 :       *chain = &DECL_CHAIN (decl);
    2437                 :             :     }
    2438                 :             : 
    2439                 :     4653799 :   return decl;
    2440                 :             : }
    2441                 :             : 
    2442                 :             : /* Like `gfc_add_field_to_struct_1', but adds alignment
    2443                 :             :    information.  */
    2444                 :             : 
    2445                 :             : tree
    2446                 :     4312733 : gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
    2447                 :             : {
    2448                 :     4312733 :   tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
    2449                 :             : 
    2450                 :     4312733 :   DECL_INITIAL (decl) = 0;
    2451                 :     4312733 :   SET_DECL_ALIGN (decl, 0);
    2452                 :     4312733 :   DECL_USER_ALIGN (decl) = 0;
    2453                 :             : 
    2454                 :     4312733 :   return decl;
    2455                 :             : }
    2456                 :             : 
    2457                 :             : 
    2458                 :             : /* Copy the backend_decl and component backend_decls if
    2459                 :             :    the two derived type symbols are "equal", as described
    2460                 :             :    in 4.4.2 and resolved by gfc_compare_derived_types.  */
    2461                 :             : 
    2462                 :             : bool
    2463                 :      297198 : gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
    2464                 :             :                            bool from_gsym)
    2465                 :             : {
    2466                 :      297198 :   gfc_component *to_cm;
    2467                 :      297198 :   gfc_component *from_cm;
    2468                 :             : 
    2469                 :      297198 :   if (from == to)
    2470                 :             :     return 1;
    2471                 :             : 
    2472                 :      258998 :   if (from->backend_decl == NULL
    2473                 :      258998 :         || !gfc_compare_derived_types (from, to))
    2474                 :      246256 :     return 0;
    2475                 :             : 
    2476                 :       12742 :   to->backend_decl = from->backend_decl;
    2477                 :             : 
    2478                 :       12742 :   to_cm = to->components;
    2479                 :       12742 :   from_cm = from->components;
    2480                 :             : 
    2481                 :             :   /* Copy the component declarations.  If a component is itself
    2482                 :             :      a derived type, we need a copy of its component declarations.
    2483                 :             :      This is done by recursing into gfc_get_derived_type and
    2484                 :             :      ensures that the component's component declarations have
    2485                 :             :      been built.  If it is a character, we need the character
    2486                 :             :      length, as well.  */
    2487                 :       48149 :   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
    2488                 :             :     {
    2489                 :       35407 :       to_cm->backend_decl = from_cm->backend_decl;
    2490                 :       35407 :       to_cm->caf_token = from_cm->caf_token;
    2491                 :       35407 :       if (from_cm->ts.type == BT_UNION)
    2492                 :          28 :         gfc_get_union_type (to_cm->ts.u.derived);
    2493                 :       35379 :       else if (from_cm->ts.type == BT_DERIVED
    2494                 :       12056 :           && (!from_cm->attr.pointer || from_gsym))
    2495                 :       11045 :         gfc_get_derived_type (to_cm->ts.u.derived);
    2496                 :       24334 :       else if (from_cm->ts.type == BT_CLASS
    2497                 :         666 :                && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
    2498                 :         659 :         gfc_get_derived_type (to_cm->ts.u.derived);
    2499                 :       23675 :       else if (from_cm->ts.type == BT_CHARACTER)
    2500                 :         761 :         to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
    2501                 :             :     }
    2502                 :             : 
    2503                 :             :   return 1;
    2504                 :             : }
    2505                 :             : 
    2506                 :             : 
    2507                 :             : /* Build a tree node for a procedure pointer component.  */
    2508                 :             : 
    2509                 :             : static tree
    2510                 :       29767 : gfc_get_ppc_type (gfc_component* c)
    2511                 :             : {
    2512                 :       29767 :   tree t;
    2513                 :             : 
    2514                 :             :   /* Explicit interface.  */
    2515                 :       29767 :   if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
    2516                 :        3008 :     return build_pointer_type (gfc_get_function_type (c->ts.interface));
    2517                 :             : 
    2518                 :             :   /* Implicit interface (only return value may be known).  */
    2519                 :       26759 :   if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
    2520                 :           3 :     t = gfc_typenode_for_spec (&c->ts);
    2521                 :             :   else
    2522                 :       26756 :     t = void_type_node;
    2523                 :             : 
    2524                 :             :   /* FIXME: it would be better to provide explicit interfaces in all
    2525                 :             :      cases, since they should be known by the compiler.  */
    2526                 :       26759 :   return build_pointer_type (build_function_type (t, NULL_TREE));
    2527                 :             : }
    2528                 :             : 
    2529                 :             : 
    2530                 :             : /* Build a tree node for a union type. Requires building each map
    2531                 :             :    structure which is an element of the union. */
    2532                 :             : 
    2533                 :             : tree
    2534                 :         252 : gfc_get_union_type (gfc_symbol *un)
    2535                 :             : {
    2536                 :         252 :     gfc_component *map = NULL;
    2537                 :         252 :     tree typenode = NULL, map_type = NULL, map_field = NULL;
    2538                 :         252 :     tree *chain = NULL;
    2539                 :             : 
    2540                 :         252 :     if (un->backend_decl)
    2541                 :             :       {
    2542                 :         130 :         if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
    2543                 :             :           return un->backend_decl;
    2544                 :             :         else
    2545                 :             :           typenode = un->backend_decl;
    2546                 :             :       }
    2547                 :             :     else
    2548                 :             :       {
    2549                 :         122 :         typenode = make_node (UNION_TYPE);
    2550                 :         122 :         TYPE_NAME (typenode) = get_identifier (un->name);
    2551                 :             :       }
    2552                 :             : 
    2553                 :             :     /* Add each contained MAP as a field. */
    2554                 :         363 :     for (map = un->components; map; map = map->next)
    2555                 :             :       {
    2556                 :         238 :         gcc_assert (map->ts.type == BT_DERIVED);
    2557                 :             : 
    2558                 :             :         /* The map's type node, which is defined within this union's context. */
    2559                 :         238 :         map_type = gfc_get_derived_type (map->ts.u.derived);
    2560                 :         238 :         TYPE_CONTEXT (map_type) = typenode;
    2561                 :             : 
    2562                 :             :         /* The map field's declaration. */
    2563                 :         238 :         map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
    2564                 :             :                                             map_type, &chain);
    2565                 :         238 :         if (map->loc.lb)
    2566                 :         238 :           gfc_set_decl_location (map_field, &map->loc);
    2567                 :           0 :         else if (un->declared_at.lb)
    2568                 :           0 :           gfc_set_decl_location (map_field, &un->declared_at);
    2569                 :             : 
    2570                 :         238 :         DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
    2571                 :         238 :         DECL_NAMELESS(map_field) = true;
    2572                 :             : 
    2573                 :             :         /* We should never clobber another backend declaration for this map,
    2574                 :             :            because each map component is unique. */
    2575                 :         238 :         if (!map->backend_decl)
    2576                 :         238 :           map->backend_decl = map_field;
    2577                 :             :       }
    2578                 :             : 
    2579                 :         125 :     un->backend_decl = typenode;
    2580                 :         125 :     gfc_finish_type (typenode);
    2581                 :             : 
    2582                 :         125 :     return typenode;
    2583                 :             : }
    2584                 :             : 
    2585                 :             : 
    2586                 :             : /* Build a tree node for a derived type.  If there are equal
    2587                 :             :    derived types, with different local names, these are built
    2588                 :             :    at the same time.  If an equal derived type has been built
    2589                 :             :    in a parent namespace, this is used.  */
    2590                 :             : 
    2591                 :             : tree
    2592                 :      163225 : gfc_get_derived_type (gfc_symbol * derived, int codimen)
    2593                 :             : {
    2594                 :      163225 :   tree typenode = NULL, field = NULL, field_type = NULL;
    2595                 :      163225 :   tree canonical = NULL_TREE;
    2596                 :      163225 :   tree *chain = NULL;
    2597                 :      163225 :   bool got_canonical = false;
    2598                 :      163225 :   bool unlimited_entity = false;
    2599                 :      163225 :   gfc_component *c;
    2600                 :      163225 :   gfc_namespace *ns;
    2601                 :      163225 :   tree tmp;
    2602                 :      163225 :   bool coarray_flag;
    2603                 :             : 
    2604                 :      326450 :   coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
    2605                 :      163225 :                  && derived->module && !derived->attr.vtype;
    2606                 :             : 
    2607                 :      163225 :   gcc_assert (!derived->attr.pdt_template);
    2608                 :             : 
    2609                 :      163225 :   if (derived->attr.unlimited_polymorphic
    2610                 :      161113 :       || (flag_coarray == GFC_FCOARRAY_LIB
    2611                 :        2004 :           && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2612                 :          36 :           && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
    2613                 :             :               || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
    2614                 :          36 :               || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
    2615                 :        2148 :     return ptr_type_node;
    2616                 :             : 
    2617                 :      161077 :   if (flag_coarray != GFC_FCOARRAY_LIB
    2618                 :      159109 :       && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
    2619                 :         410 :       && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
    2620                 :         410 :           || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
    2621                 :         298 :     return gfc_get_int_type (gfc_default_integer_kind);
    2622                 :             : 
    2623                 :      160779 :   if (derived && derived->attr.flavor == FL_PROCEDURE
    2624                 :          52 :       && derived->attr.generic)
    2625                 :          52 :     derived = gfc_find_dt_in_generic (derived);
    2626                 :             : 
    2627                 :             :   /* See if it's one of the iso_c_binding derived types.  */
    2628                 :      160779 :   if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
    2629                 :             :     {
    2630                 :       12337 :       if (derived->backend_decl)
    2631                 :             :         return derived->backend_decl;
    2632                 :             : 
    2633                 :        4918 :       if (derived->intmod_sym_id == ISOCBINDING_PTR)
    2634                 :        2630 :         derived->backend_decl = ptr_type_node;
    2635                 :             :       else
    2636                 :        2288 :         derived->backend_decl = pfunc_type_node;
    2637                 :             : 
    2638                 :        4918 :       derived->ts.kind = gfc_index_integer_kind;
    2639                 :        4918 :       derived->ts.type = BT_INTEGER;
    2640                 :             :       /* Set the f90_type to BT_VOID as a way to recognize something of type
    2641                 :             :          BT_INTEGER that needs to fit a void * for the purpose of the
    2642                 :             :          iso_c_binding derived types.  */
    2643                 :        4918 :       derived->ts.f90_type = BT_VOID;
    2644                 :             : 
    2645                 :        4918 :       return derived->backend_decl;
    2646                 :             :     }
    2647                 :             : 
    2648                 :             :   /* If use associated, use the module type for this one.  */
    2649                 :      148442 :   if (derived->backend_decl == NULL
    2650                 :       35823 :       && (derived->attr.use_assoc || derived->attr.used_in_submodule)
    2651                 :        9598 :       && derived->module
    2652                 :      158040 :       && gfc_get_module_backend_decl (derived))
    2653                 :        9276 :     goto copy_derived_types;
    2654                 :             : 
    2655                 :             :   /* The derived types from an earlier namespace can be used as the
    2656                 :             :      canonical type.  */
    2657                 :      139166 :   if (derived->backend_decl == NULL
    2658                 :             :       && !derived->attr.use_assoc
    2659                 :       26547 :       && !derived->attr.used_in_submodule
    2660                 :       26225 :       && gfc_global_ns_list)
    2661                 :             :     {
    2662                 :        7221 :       for (ns = gfc_global_ns_list;
    2663                 :       33425 :            ns->translated && !got_canonical;
    2664                 :        7221 :            ns = ns->sibling)
    2665                 :             :         {
    2666                 :        7221 :           if (ns->derived_types)
    2667                 :             :             {
    2668                 :       25998 :               for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical;
    2669                 :             :                    dt = dt->dt_next)
    2670                 :             :                 {
    2671                 :       25781 :                   gfc_copy_dt_decls_ifequal (dt, derived, true);
    2672                 :       25781 :                   if (derived->backend_decl)
    2673                 :         356 :                     got_canonical = true;
    2674                 :       25781 :                   if (dt->dt_next == ns->derived_types)
    2675                 :             :                     break;
    2676                 :             :                 }
    2677                 :             :             }
    2678                 :             :         }
    2679                 :             :     }
    2680                 :             : 
    2681                 :             :   /* Store up the canonical type to be added to this one.  */
    2682                 :       26204 :   if (got_canonical)
    2683                 :             :     {
    2684                 :         356 :       if (TYPE_CANONICAL (derived->backend_decl))
    2685                 :         356 :         canonical = TYPE_CANONICAL (derived->backend_decl);
    2686                 :             :       else
    2687                 :             :         canonical = derived->backend_decl;
    2688                 :             : 
    2689                 :         356 :       derived->backend_decl = NULL_TREE;
    2690                 :             :     }
    2691                 :             : 
    2692                 :             :   /* derived->backend_decl != 0 means we saw it before, but its
    2693                 :             :      components' backend_decl may have not been built.  */
    2694                 :      139166 :   if (derived->backend_decl)
    2695                 :             :     {
    2696                 :             :       /* Its components' backend_decl have been built or we are
    2697                 :             :          seeing recursion through the formal arglist of a procedure
    2698                 :             :          pointer component.  */
    2699                 :      112619 :       if (TYPE_FIELDS (derived->backend_decl))
    2700                 :             :         return derived->backend_decl;
    2701                 :        4623 :       else if (derived->attr.abstract
    2702                 :        4623 :                && derived->attr.proc_pointer_comp)
    2703                 :             :         {
    2704                 :             :           /* If an abstract derived type with procedure pointer
    2705                 :             :              components has no other type of component, return the
    2706                 :             :              backend_decl. Otherwise build the components if any of the
    2707                 :             :              non-procedure pointer components have no backend_decl.  */
    2708                 :          13 :           for (c = derived->components; c; c = c->next)
    2709                 :             :             {
    2710                 :          26 :               bool same_alloc_type = c->attr.allocatable
    2711                 :          13 :                                      && derived == c->ts.u.derived;
    2712                 :          13 :               if (!c->attr.proc_pointer
    2713                 :           1 :                   && !same_alloc_type
    2714                 :           1 :                   && c->backend_decl == NULL)
    2715                 :             :                 break;
    2716                 :          12 :               else if (c->next == NULL)
    2717                 :             :                 return derived->backend_decl;
    2718                 :             :             }
    2719                 :             :           typenode = derived->backend_decl;
    2720                 :             :         }
    2721                 :             :       else
    2722                 :             :         typenode = derived->backend_decl;
    2723                 :             :     }
    2724                 :             :   else
    2725                 :             :     {
    2726                 :             :       /* We see this derived type first time, so build the type node.  */
    2727                 :       26547 :       typenode = make_node (RECORD_TYPE);
    2728                 :       26547 :       TYPE_NAME (typenode) = get_identifier (derived->name);
    2729                 :       26547 :       TYPE_PACKED (typenode) = flag_pack_derived;
    2730                 :       26547 :       derived->backend_decl = typenode;
    2731                 :             :     }
    2732                 :             : 
    2733                 :       31164 :   if (derived->components
    2734                 :       25747 :         && derived->components->ts.type == BT_DERIVED
    2735                 :        8851 :         && strcmp (derived->components->name, "_data") == 0
    2736                 :        6372 :         && derived->components->ts.u.derived->attr.unlimited_polymorphic)
    2737                 :       31164 :     unlimited_entity = true;
    2738                 :             : 
    2739                 :             :   /* Go through the derived type components, building them as
    2740                 :             :      necessary. The reason for doing this now is that it is
    2741                 :             :      possible to recurse back to this derived type through a
    2742                 :             :      pointer component (PR24092). If this happens, the fields
    2743                 :             :      will be built and so we can return the type.  */
    2744                 :      128589 :   for (c = derived->components; c; c = c->next)
    2745                 :             :     {
    2746                 :      194850 :       bool same_alloc_type = c->attr.allocatable
    2747                 :       97425 :                              && derived == c->ts.u.derived;
    2748                 :             : 
    2749                 :       97425 :       if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
    2750                 :         108 :         c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);
    2751                 :             : 
    2752                 :       97425 :       if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
    2753                 :       63336 :         continue;
    2754                 :             : 
    2755                 :       34089 :       if ((!c->attr.pointer && !c->attr.proc_pointer
    2756                 :        5692 :           && !same_alloc_type)
    2757                 :       28442 :           || c->ts.u.derived->backend_decl == NULL)
    2758                 :             :         {
    2759                 :        8287 :           int local_codim = c->attr.codimension ? c->as->corank: codimen;
    2760                 :        8287 :           c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
    2761                 :             :                                                                 local_codim);
    2762                 :             :         }
    2763                 :             : 
    2764                 :       34089 :       if (c->ts.u.derived->attr.is_iso_c)
    2765                 :             :         {
    2766                 :             :           /* Need to copy the modified ts from the derived type.  The
    2767                 :             :              typespec was modified because C_PTR/C_FUNPTR are translated
    2768                 :             :              into (void *) from derived types.  */
    2769                 :          22 :           c->ts.type = c->ts.u.derived->ts.type;
    2770                 :          22 :           c->ts.kind = c->ts.u.derived->ts.kind;
    2771                 :          22 :           c->ts.f90_type = c->ts.u.derived->ts.f90_type;
    2772                 :          22 :           if (c->initializer)
    2773                 :             :             {
    2774                 :          21 :               c->initializer->ts.type = c->ts.type;
    2775                 :          21 :               c->initializer->ts.kind = c->ts.kind;
    2776                 :          21 :               c->initializer->ts.f90_type = c->ts.f90_type;
    2777                 :          21 :               c->initializer->expr_type = EXPR_NULL;
    2778                 :             :             }
    2779                 :             :         }
    2780                 :             :     }
    2781                 :             : 
    2782                 :       31164 :   if (TYPE_FIELDS (derived->backend_decl))
    2783                 :             :     return derived->backend_decl;
    2784                 :             : 
    2785                 :             :   /* Build the type member list. Install the newly created RECORD_TYPE
    2786                 :             :      node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
    2787                 :             :      through only the top-level linked list of components so we correctly
    2788                 :             :      build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
    2789                 :             :      types are built as part of gfc_get_union_type.  */
    2790                 :      128401 :   for (c = derived->components; c; c = c->next)
    2791                 :             :     {
    2792                 :      194610 :       bool same_alloc_type = c->attr.allocatable
    2793                 :       97305 :                              && derived == c->ts.u.derived;
    2794                 :             :       /* Prevent infinite recursion, when the procedure pointer type is
    2795                 :             :          the same as derived, by forcing the procedure pointer component to
    2796                 :             :          be built as if the explicit interface does not exist.  */
    2797                 :       97305 :       if (c->attr.proc_pointer
    2798                 :       29805 :           && (c->ts.type != BT_DERIVED || (c->ts.u.derived
    2799                 :         163 :                     && !gfc_compare_derived_types (derived, c->ts.u.derived)))
    2800                 :      127086 :           && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
    2801                 :         304 :                     && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
    2802                 :       29767 :         field_type = gfc_get_ppc_type (c);
    2803                 :       67538 :       else if (c->attr.proc_pointer && derived->backend_decl)
    2804                 :             :         {
    2805                 :          38 :           tmp = build_function_type (derived->backend_decl, NULL_TREE);
    2806                 :          38 :           field_type = build_pointer_type (tmp);
    2807                 :             :         }
    2808                 :       67500 :       else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
    2809                 :       33494 :         field_type = c->ts.u.derived->backend_decl;
    2810                 :       34006 :       else if (c->attr.caf_token)
    2811                 :         109 :         field_type = pvoid_type_node;
    2812                 :             :       else
    2813                 :             :         {
    2814                 :       33897 :           if (c->ts.type == BT_CHARACTER
    2815                 :        1768 :               && !c->ts.deferred && !c->attr.pdt_string)
    2816                 :             :             {
    2817                 :             :               /* Evaluate the string length.  */
    2818                 :        1361 :               gfc_conv_const_charlen (c->ts.u.cl);
    2819                 :        1361 :               gcc_assert (c->ts.u.cl->backend_decl);
    2820                 :             :             }
    2821                 :       32536 :           else if (c->ts.type == BT_CHARACTER)
    2822                 :         407 :             c->ts.u.cl->backend_decl
    2823                 :         407 :                         = build_int_cst (gfc_charlen_type_node, 0);
    2824                 :             : 
    2825                 :       33897 :           field_type = gfc_typenode_for_spec (&c->ts, codimen);
    2826                 :             :         }
    2827                 :             : 
    2828                 :             :       /* This returns an array descriptor type.  Initialization may be
    2829                 :             :          required.  */
    2830                 :       97305 :       if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
    2831                 :             :         {
    2832                 :        5909 :           if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
    2833                 :             :             {
    2834                 :        4595 :               enum gfc_array_kind akind;
    2835                 :        4595 :               if (c->attr.pointer)
    2836                 :        1804 :                 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
    2837                 :             :                                            : GFC_ARRAY_POINTER;
    2838                 :             :               else
    2839                 :             :                 akind = GFC_ARRAY_ALLOCATABLE;
    2840                 :             :               /* Pointers to arrays aren't actually pointer types.  The
    2841                 :             :                  descriptors are separate, but the data is common.  */
    2842                 :        4595 :               field_type = gfc_build_array_type (field_type, c->as, akind,
    2843                 :             :                                                  !c->attr.target
    2844                 :             :                                                  && !c->attr.pointer,
    2845                 :             :                                                  c->attr.contiguous,
    2846                 :             :                                                  codimen);
    2847                 :        4595 :             }
    2848                 :             :           else
    2849                 :        1314 :             field_type = gfc_get_nodesc_array_type (field_type, c->as,
    2850                 :             :                                                     PACKED_STATIC,
    2851                 :             :                                                     !c->attr.target);
    2852                 :             :         }
    2853                 :       91396 :       else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
    2854                 :       30148 :                && !c->attr.proc_pointer
    2855                 :       29998 :                && !(unlimited_entity && c == derived->components))
    2856                 :       29549 :         field_type = build_pointer_type (field_type);
    2857                 :             : 
    2858                 :       97305 :       if (c->attr.pointer || same_alloc_type)
    2859                 :       30001 :         field_type = gfc_nonrestricted_type (field_type);
    2860                 :             : 
    2861                 :             :       /* vtype fields can point to different types to the base type.  */
    2862                 :       97305 :       if (c->ts.type == BT_DERIVED
    2863                 :       32988 :             && c->ts.u.derived && c->ts.u.derived->attr.vtype)
    2864                 :       14787 :           field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
    2865                 :             :                                                     ptr_mode, true);
    2866                 :             : 
    2867                 :             :       /* Ensure that the CLASS language specific flag is set.  */
    2868                 :       97305 :       if (c->ts.type == BT_CLASS)
    2869                 :             :         {
    2870                 :         973 :           if (POINTER_TYPE_P (field_type))
    2871                 :         304 :             GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
    2872                 :             :           else
    2873                 :         669 :             GFC_CLASS_TYPE_P (field_type) = 1;
    2874                 :             :         }
    2875                 :             : 
    2876                 :       97305 :       field = gfc_add_field_to_struct (typenode,
    2877                 :             :                                        get_identifier (c->name),
    2878                 :             :                                        field_type, &chain);
    2879                 :       97305 :       if (c->loc.lb)
    2880                 :       97305 :         gfc_set_decl_location (field, &c->loc);
    2881                 :           0 :       else if (derived->declared_at.lb)
    2882                 :           0 :         gfc_set_decl_location (field, &derived->declared_at);
    2883                 :             : 
    2884                 :       97305 :       gfc_finish_decl_attrs (field, &c->attr);
    2885                 :             : 
    2886                 :       97305 :       DECL_PACKED (field) |= TYPE_PACKED (typenode);
    2887                 :             : 
    2888                 :       97305 :       gcc_assert (field);
    2889                 :       97305 :       if (!c->backend_decl)
    2890                 :       96030 :         c->backend_decl = field;
    2891                 :             : 
    2892                 :       97305 :       if (c->attr.pointer && c->attr.dimension
    2893                 :        1788 :           && !(c->ts.type == BT_DERIVED
    2894                 :        1364 :                && strcmp (c->name, "_data") == 0))
    2895                 :         554 :         GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
    2896                 :             :     }
    2897                 :             : 
    2898                 :             :   /* Now lay out the derived type, including the fields.  */
    2899                 :       31096 :   if (canonical)
    2900                 :         356 :     TYPE_CANONICAL (typenode) = canonical;
    2901                 :             : 
    2902                 :       31096 :   gfc_finish_type (typenode);
    2903                 :       31096 :   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
    2904                 :       31096 :   if (derived->module && derived->ns->proc_name
    2905                 :       18454 :       && derived->ns->proc_name->attr.flavor == FL_MODULE)
    2906                 :             :     {
    2907                 :       17430 :       if (derived->ns->proc_name->backend_decl
    2908                 :       17416 :           && TREE_CODE (derived->ns->proc_name->backend_decl)
    2909                 :             :              == NAMESPACE_DECL)
    2910                 :             :         {
    2911                 :       17416 :           TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
    2912                 :       17416 :           DECL_CONTEXT (TYPE_STUB_DECL (typenode))
    2913                 :       34832 :             = derived->ns->proc_name->backend_decl;
    2914                 :             :         }
    2915                 :             :     }
    2916                 :             : 
    2917                 :       31096 :   derived->backend_decl = typenode;
    2918                 :             : 
    2919                 :       40372 : copy_derived_types:
    2920                 :             : 
    2921                 :      164524 :   for (c = derived->components; c; c = c->next)
    2922                 :             :     {
    2923                 :             :       /* Do not add a caf_token field for class container components.  */
    2924                 :      124152 :       if ((codimen || coarray_flag)
    2925                 :         669 :           && !c->attr.dimension && !c->attr.codimension
    2926                 :         358 :           && (c->attr.allocatable || c->attr.pointer)
    2927                 :          86 :           && !derived->attr.is_class)
    2928                 :             :         {
    2929                 :             :           /* Provide sufficient space to hold "_caf_symbol".  */
    2930                 :          84 :           char caf_name[GFC_MAX_SYMBOL_LEN + 6];
    2931                 :          84 :           gfc_component *token;
    2932                 :          84 :           snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
    2933                 :          84 :           token = gfc_find_component (derived, caf_name, true, true, NULL);
    2934                 :          84 :           gcc_assert (token);
    2935                 :          84 :           c->caf_token = token->backend_decl;
    2936                 :          84 :           suppress_warning (c->caf_token);
    2937                 :             :         }
    2938                 :             :     }
    2939                 :             : 
    2940                 :      261339 :   for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
    2941                 :             :     {
    2942                 :      260808 :       gfc_copy_dt_decls_ifequal (derived, dt, false);
    2943                 :      260808 :       if (dt->dt_next == gfc_derived_types)
    2944                 :             :         break;
    2945                 :             :     }
    2946                 :             : 
    2947                 :       40372 :   return derived->backend_decl;
    2948                 :             : }
    2949                 :             : 
    2950                 :             : 
    2951                 :             : bool
    2952                 :      800181 : gfc_return_by_reference (gfc_symbol * sym)
    2953                 :             : {
    2954                 :      800181 :   if (!sym->attr.function)
    2955                 :             :     return 0;
    2956                 :             : 
    2957                 :      394855 :   if (sym->attr.dimension)
    2958                 :             :     return 1;
    2959                 :             : 
    2960                 :      333149 :   if (sym->ts.type == BT_CHARACTER
    2961                 :       19907 :       && !sym->attr.is_bind_c
    2962                 :       19373 :       && (!sym->attr.result
    2963                 :          16 :           || !sym->ns->proc_name
    2964                 :          16 :           || !sym->ns->proc_name->attr.is_bind_c))
    2965                 :             :     return 1;
    2966                 :             : 
    2967                 :             :   /* Possibly return complex numbers by reference for g77 compatibility.
    2968                 :             :      We don't do this for calls to intrinsics (as the library uses the
    2969                 :             :      -fno-f2c calling convention), nor for calls to functions which always
    2970                 :             :      require an explicit interface, as no compatibility problems can
    2971                 :             :      arise there.  */
    2972                 :      313776 :   if (flag_f2c && sym->ts.type == BT_COMPLEX
    2973                 :             :       && !sym->attr.pointer
    2974                 :             :       && !sym->attr.allocatable
    2975                 :        1800 :       && !sym->attr.intrinsic && !sym->attr.always_explicit)
    2976                 :         624 :     return 1;
    2977                 :             : 
    2978                 :             :   return 0;
    2979                 :             : }
    2980                 :             : 
    2981                 :             : static tree
    2982                 :          96 : gfc_get_mixed_entry_union (gfc_namespace *ns)
    2983                 :             : {
    2984                 :          96 :   tree type;
    2985                 :          96 :   tree *chain = NULL;
    2986                 :          96 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2987                 :          96 :   gfc_entry_list *el, *el2;
    2988                 :             : 
    2989                 :          96 :   gcc_assert (ns->proc_name->attr.mixed_entry_master);
    2990                 :          96 :   gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
    2991                 :             : 
    2992                 :          96 :   snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
    2993                 :             : 
    2994                 :             :   /* Build the type node.  */
    2995                 :          96 :   type = make_node (UNION_TYPE);
    2996                 :             : 
    2997                 :          96 :   TYPE_NAME (type) = get_identifier (name);
    2998                 :             : 
    2999                 :         306 :   for (el = ns->entries; el; el = el->next)
    3000                 :             :     {
    3001                 :             :       /* Search for duplicates.  */
    3002                 :         342 :       for (el2 = ns->entries; el2 != el; el2 = el2->next)
    3003                 :         132 :         if (el2->sym->result == el->sym->result)
    3004                 :             :           break;
    3005                 :             : 
    3006                 :         210 :       if (el == el2)
    3007                 :         210 :         gfc_add_field_to_struct_1 (type,
    3008                 :         210 :                                    get_identifier (el->sym->result->name),
    3009                 :         210 :                                    gfc_sym_type (el->sym->result), &chain);
    3010                 :             :     }
    3011                 :             : 
    3012                 :             :   /* Finish off the type.  */
    3013                 :          96 :   gfc_finish_type (type);
    3014                 :          96 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
    3015                 :          96 :   return type;
    3016                 :             : }
    3017                 :             : 
    3018                 :             : /* Create a "fn spec" based on the formal arguments;
    3019                 :             :    cf. create_function_arglist.  */
    3020                 :             : 
    3021                 :             : static tree
    3022                 :       93642 : create_fn_spec (gfc_symbol *sym, tree fntype)
    3023                 :             : {
    3024                 :       93642 :   char spec[150];
    3025                 :       93642 :   size_t spec_len;
    3026                 :       93642 :   gfc_formal_arglist *f;
    3027                 :       93642 :   tree tmp;
    3028                 :             : 
    3029                 :       93642 :   memset (&spec, 0, sizeof (spec));
    3030                 :       93642 :   spec[0] = '.';
    3031                 :       93642 :   spec[1] = ' ';
    3032                 :       93642 :   spec_len = 2;
    3033                 :             : 
    3034                 :       93642 :   if (sym->attr.entry_master)
    3035                 :             :     {
    3036                 :         631 :       spec[spec_len++] = 'R';
    3037                 :         631 :       spec[spec_len++] = ' ';
    3038                 :             :     }
    3039                 :       93642 :   if (gfc_return_by_reference (sym))
    3040                 :             :     {
    3041                 :        8361 :       gfc_symbol *result = sym->result ? sym->result : sym;
    3042                 :             : 
    3043                 :        8361 :       if (result->attr.pointer || sym->attr.proc_pointer)
    3044                 :             :         {
    3045                 :         286 :           spec[spec_len++] = '.';
    3046                 :         286 :           spec[spec_len++] = ' ';
    3047                 :             :         }
    3048                 :             :       else
    3049                 :             :         {
    3050                 :        8075 :           spec[spec_len++] = 'w';
    3051                 :        8075 :           spec[spec_len++] = ' ';
    3052                 :             :         }
    3053                 :        8361 :       if (sym->ts.type == BT_CHARACTER)
    3054                 :             :         {
    3055                 :        2652 :           if (!sym->ts.u.cl->length
    3056                 :         462 :               && (sym->attr.allocatable || sym->attr.pointer))
    3057                 :         240 :             spec[spec_len++] = 'w';
    3058                 :             :           else
    3059                 :        2412 :             spec[spec_len++] = 'R';
    3060                 :        2652 :           spec[spec_len++] = ' ';
    3061                 :             :         }
    3062                 :             :     }
    3063                 :             : 
    3064                 :      214939 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3065                 :      121297 :     if (spec_len < sizeof (spec))
    3066                 :             :       {
    3067                 :      121297 :         bool is_class = false;
    3068                 :      121297 :         bool is_pointer = false;
    3069                 :             : 
    3070                 :      121297 :         if (f->sym)
    3071                 :             :           {
    3072                 :        8417 :             is_class = f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
    3073                 :      129610 :               && f->sym->attr.class_ok;
    3074                 :      121193 :             is_pointer = is_class ? CLASS_DATA (f->sym)->attr.class_pointer
    3075                 :      112776 :                                   : f->sym->attr.pointer;
    3076                 :             :           }
    3077                 :             : 
    3078                 :      121297 :         if (f->sym == NULL || is_pointer || f->sym->attr.target
    3079                 :      117429 :             || f->sym->attr.external || f->sym->attr.cray_pointer
    3080                 :      114601 :             || (f->sym->ts.type == BT_DERIVED
    3081                 :       20566 :                 && (f->sym->ts.u.derived->attr.proc_pointer_comp
    3082                 :       20566 :                     || f->sym->ts.u.derived->attr.pointer_comp))
    3083                 :      112097 :             || (is_class
    3084                 :        7568 :                 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
    3085                 :        7568 :                     || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
    3086                 :      110885 :             || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
    3087                 :             :           {
    3088                 :       17558 :             spec[spec_len++] = '.';
    3089                 :       17558 :             spec[spec_len++] = ' ';
    3090                 :             :           }
    3091                 :      103739 :         else if (f->sym->attr.intent == INTENT_IN)
    3092                 :             :           {
    3093                 :       45551 :             spec[spec_len++] = 'r';
    3094                 :       45551 :             spec[spec_len++] = ' ';
    3095                 :             :           }
    3096                 :       58188 :         else if (f->sym)
    3097                 :             :           {
    3098                 :       58188 :             spec[spec_len++] = 'w';
    3099                 :       58188 :             spec[spec_len++] = ' ';
    3100                 :             :           }
    3101                 :             :       }
    3102                 :             : 
    3103                 :       93642 :   tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
    3104                 :       93642 :   tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
    3105                 :       93642 :   return build_type_attribute_variant (fntype, tmp);
    3106                 :             : }
    3107                 :             : 
    3108                 :             : 
    3109                 :             : /* NOTE: The returned function type must match the argument list created by
    3110                 :             :    create_function_arglist.  */
    3111                 :             : 
    3112                 :             : tree
    3113                 :       95403 : gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
    3114                 :             :                        const char *fnspec)
    3115                 :             : {
    3116                 :       95403 :   tree type;
    3117                 :       95403 :   vec<tree, va_gc> *typelist = NULL;
    3118                 :       95403 :   vec<tree, va_gc> *hidden_typelist = NULL;
    3119                 :       95403 :   gfc_formal_arglist *f;
    3120                 :       95403 :   gfc_symbol *arg;
    3121                 :       95403 :   int alternate_return = 0;
    3122                 :       95403 :   bool is_varargs = true;
    3123                 :             : 
    3124                 :             :   /* Make sure this symbol is a function, a subroutine or the main
    3125                 :             :      program.  */
    3126                 :       95403 :   gcc_assert (sym->attr.flavor == FL_PROCEDURE
    3127                 :             :               || sym->attr.flavor == FL_PROGRAM);
    3128                 :             : 
    3129                 :             :   /* To avoid recursing infinitely on recursive types, we use error_mark_node
    3130                 :             :      so that they can be detected here and handled further down.  */
    3131                 :       95403 :   if (sym->backend_decl == NULL)
    3132                 :       95223 :     sym->backend_decl = error_mark_node;
    3133                 :         180 :   else if (sym->backend_decl == error_mark_node)
    3134                 :          27 :     goto arg_type_list_done;
    3135                 :         153 :   else if (sym->attr.proc_pointer)
    3136                 :           0 :     return TREE_TYPE (TREE_TYPE (sym->backend_decl));
    3137                 :             :   else
    3138                 :         153 :     return TREE_TYPE (sym->backend_decl);
    3139                 :             : 
    3140                 :       95223 :   if (sym->attr.entry_master)
    3141                 :             :     /* Additional parameter for selecting an entry point.  */
    3142                 :         631 :     vec_safe_push (typelist, gfc_array_index_type);
    3143                 :             : 
    3144                 :       95223 :   if (sym->result)
    3145                 :       28570 :     arg = sym->result;
    3146                 :             :   else
    3147                 :             :     arg = sym;
    3148                 :             : 
    3149                 :       95223 :   if (arg->ts.type == BT_CHARACTER)
    3150                 :        2955 :     gfc_conv_const_charlen (arg->ts.u.cl);
    3151                 :             : 
    3152                 :             :   /* Some functions we use an extra parameter for the return value.  */
    3153                 :       95223 :   if (gfc_return_by_reference (sym))
    3154                 :             :     {
    3155                 :        9887 :       type = gfc_sym_type (arg);
    3156                 :        9887 :       if (arg->ts.type == BT_COMPLEX
    3157                 :        9566 :           || arg->attr.dimension
    3158                 :        1440 :           || arg->ts.type == BT_CHARACTER)
    3159                 :        9887 :         type = build_reference_type (type);
    3160                 :             : 
    3161                 :        9887 :       vec_safe_push (typelist, type);
    3162                 :        9887 :       if (arg->ts.type == BT_CHARACTER)
    3163                 :             :         {
    3164                 :        2892 :           if (!arg->ts.deferred)
    3165                 :             :             /* Transfer by value.  */
    3166                 :        2604 :             vec_safe_push (typelist, gfc_charlen_type_node);
    3167                 :             :           else
    3168                 :             :             /* Deferred character lengths are transferred by reference
    3169                 :             :                so that the value can be returned.  */
    3170                 :         288 :             vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
    3171                 :             :         }
    3172                 :             :     }
    3173                 :       95223 :   if (sym->backend_decl == error_mark_node && actual_args != NULL
    3174                 :       13291 :       && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
    3175                 :         995 :                                  || sym->attr.proc == PROC_UNKNOWN))
    3176                 :         737 :     gfc_get_formal_from_actual_arglist (sym, actual_args);
    3177                 :             : 
    3178                 :             :   /* Build the argument types for the function.  */
    3179                 :      221091 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3180                 :             :     {
    3181                 :      125868 :       arg = f->sym;
    3182                 :      125868 :       if (arg)
    3183                 :             :         {
    3184                 :             :           /* Evaluate constant character lengths here so that they can be
    3185                 :             :              included in the type.  */
    3186                 :      125764 :           if (arg->ts.type == BT_CHARACTER)
    3187                 :       11428 :             gfc_conv_const_charlen (arg->ts.u.cl);
    3188                 :             : 
    3189                 :      125764 :           if (arg->attr.flavor == FL_PROCEDURE)
    3190                 :             :             {
    3191                 :         961 :               type = gfc_get_function_type (arg);
    3192                 :         961 :               type = build_pointer_type (type);
    3193                 :             :             }
    3194                 :             :           else
    3195                 :      124803 :             type = gfc_sym_type (arg, sym->attr.is_bind_c);
    3196                 :             : 
    3197                 :             :           /* Parameter Passing Convention
    3198                 :             : 
    3199                 :             :              We currently pass all parameters by reference.
    3200                 :             :              Parameters with INTENT(IN) could be passed by value.
    3201                 :             :              The problem arises if a function is called via an implicit
    3202                 :             :              prototype. In this situation the INTENT is not known.
    3203                 :             :              For this reason all parameters to global functions must be
    3204                 :             :              passed by reference.  Passing by value would potentially
    3205                 :             :              generate bad code.  Worse there would be no way of telling that
    3206                 :             :              this code was bad, except that it would give incorrect results.
    3207                 :             : 
    3208                 :             :              Contained procedures could pass by value as these are never
    3209                 :             :              used without an explicit interface, and cannot be passed as
    3210                 :             :              actual parameters for a dummy procedure.  */
    3211                 :             : 
    3212                 :      125764 :           vec_safe_push (typelist, type);
    3213                 :             :         }
    3214                 :             :       else
    3215                 :             :         {
    3216                 :         104 :           if (sym->attr.subroutine)
    3217                 :      125868 :             alternate_return = 1;
    3218                 :             :         }
    3219                 :             :     }
    3220                 :             : 
    3221                 :             :   /* Add hidden arguments.  */
    3222                 :      221091 :   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    3223                 :             :     {
    3224                 :      125868 :       arg = f->sym;
    3225                 :             :       /* Add hidden string length parameters.  */
    3226                 :      125868 :       if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
    3227                 :             :         {
    3228                 :        9367 :           if (!arg->ts.deferred)
    3229                 :             :             /* Transfer by value.  */
    3230                 :        8894 :             type = gfc_charlen_type_node;
    3231                 :             :           else
    3232                 :             :             /* Deferred character lengths are transferred by reference
    3233                 :             :                so that the value can be returned.  */
    3234                 :         473 :             type = build_pointer_type (gfc_charlen_type_node);
    3235                 :             : 
    3236                 :        9367 :           vec_safe_push (hidden_typelist, type);
    3237                 :             :         }
    3238                 :             :       /* For scalar intrinsic types, VALUE passes the value,
    3239                 :             :          hence, the optional status cannot be transferred via a NULL pointer.
    3240                 :             :          Thus, we will use a hidden argument in that case.  */
    3241                 :             :       if (arg
    3242                 :             :           && arg->attr.optional
    3243                 :             :           && arg->attr.value
    3244                 :      125764 :           && !arg->attr.dimension
    3245                 :         456 :           && arg->ts.type != BT_CLASS
    3246                 :             :           && !gfc_bt_struct (arg->ts.type))
    3247                 :         456 :         vec_safe_push (typelist, boolean_type_node);
    3248                 :             :       /* Coarrays which are descriptorless or assumed-shape pass with
    3249                 :             :          -fcoarray=lib the token and the offset as hidden arguments.  */
    3250                 :         560 :       if (arg
    3251                 :      125764 :           && flag_coarray == GFC_FCOARRAY_LIB
    3252                 :         372 :           && ((arg->ts.type != BT_CLASS
    3253                 :             :                && arg->attr.codimension
    3254                 :         360 :                && !arg->attr.allocatable)
    3255                 :         322 :               || (arg->ts.type == BT_CLASS
    3256                 :          12 :                   && CLASS_DATA (arg)->attr.codimension
    3257                 :          12 :                   && !CLASS_DATA (arg)->attr.allocatable)))
    3258                 :             :         {
    3259                 :          59 :           vec_safe_push (hidden_typelist, pvoid_type_node);  /* caf_token.  */
    3260                 :          59 :           vec_safe_push (hidden_typelist, gfc_array_index_type);  /* caf_offset.  */
    3261                 :             :         }
    3262                 :             :     }
    3263                 :             : 
    3264                 :             :   /* Put hidden character length, caf_token, caf_offset at the end.  */
    3265                 :      101790 :   vec_safe_reserve (typelist, vec_safe_length (hidden_typelist));
    3266                 :       95223 :   vec_safe_splice (typelist, hidden_typelist);
    3267                 :             : 
    3268                 :       95223 :   if (!vec_safe_is_empty (typelist)
    3269                 :             :       || sym->attr.is_main_program
    3270                 :       37570 :       || sym->attr.if_source != IFSRC_UNKNOWN)
    3271                 :             :     is_varargs = false;
    3272                 :             : 
    3273                 :       95223 :   if (sym->backend_decl == error_mark_node)
    3274                 :       95223 :     sym->backend_decl = NULL_TREE;
    3275                 :             : 
    3276                 :       95250 : arg_type_list_done:
    3277                 :             : 
    3278                 :       95250 :   if (alternate_return)
    3279                 :          74 :     type = integer_type_node;
    3280                 :       95176 :   else if (!sym->attr.function || gfc_return_by_reference (sym))
    3281                 :       76098 :     type = void_type_node;
    3282                 :       19078 :   else if (sym->attr.mixed_entry_master)
    3283                 :          96 :     type = gfc_get_mixed_entry_union (sym->ns);
    3284                 :       18982 :   else if (flag_f2c && sym->ts.type == BT_REAL
    3285                 :         393 :            && sym->ts.kind == gfc_default_real_kind
    3286                 :             :            && !sym->attr.pointer
    3287                 :         219 :            && !sym->attr.allocatable
    3288                 :         171 :            && !sym->attr.always_explicit)
    3289                 :             :     {
    3290                 :             :       /* Special case: f2c calling conventions require that (scalar)
    3291                 :             :          default REAL functions return the C type double instead.  f2c
    3292                 :             :          compatibility is only an issue with functions that don't
    3293                 :             :          require an explicit interface, as only these could be
    3294                 :             :          implemented in Fortran 77.  */
    3295                 :         171 :       sym->ts.kind = gfc_default_double_kind;
    3296                 :         171 :       type = gfc_typenode_for_spec (&sym->ts);
    3297                 :         171 :       sym->ts.kind = gfc_default_real_kind;
    3298                 :             :     }
    3299                 :       18811 :   else if (sym->result && sym->result->attr.proc_pointer)
    3300                 :             :     /* Procedure pointer return values.  */
    3301                 :             :     {
    3302                 :         443 :       if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
    3303                 :             :         {
    3304                 :             :           /* Unset proc_pointer as gfc_get_function_type
    3305                 :             :              is called recursively.  */
    3306                 :         151 :           sym->result->attr.proc_pointer = 0;
    3307                 :         151 :           type = build_pointer_type (gfc_get_function_type (sym->result));
    3308                 :         151 :           sym->result->attr.proc_pointer = 1;
    3309                 :             :         }
    3310                 :             :       else
    3311                 :         292 :        type = gfc_sym_type (sym->result);
    3312                 :             :     }
    3313                 :             :   else
    3314                 :       18368 :     type = gfc_sym_type (sym);
    3315                 :             : 
    3316                 :       95250 :   if (is_varargs)
    3317                 :             :     /* This should be represented as an unprototyped type, not a type
    3318                 :             :        with (...) prototype.  */
    3319                 :        1848 :     type = build_function_type (type, NULL_TREE);
    3320                 :             :   else
    3321                 :      208708 :     type = build_function_type_vec (type, typelist);
    3322                 :             : 
    3323                 :             :   /* If we were passed an fn spec, add it here, otherwise determine it from
    3324                 :             :      the formal arguments.  */
    3325                 :       95250 :   if (fnspec)
    3326                 :             :     {
    3327                 :        1608 :       tree tmp;
    3328                 :        1608 :       int spec_len = strlen (fnspec);
    3329                 :        1608 :       tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec));
    3330                 :        1608 :       tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type));
    3331                 :        1608 :       type = build_type_attribute_variant (type, tmp);
    3332                 :             :     }
    3333                 :             :   else
    3334                 :       93642 :     type = create_fn_spec (sym, type);
    3335                 :             : 
    3336                 :       95250 :   return type;
    3337                 :             : }
    3338                 :             : 
    3339                 :             : /* Language hooks for middle-end access to type nodes.  */
    3340                 :             : 
    3341                 :             : /* Return an integer type with BITS bits of precision,
    3342                 :             :    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
    3343                 :             : 
    3344                 :             : tree
    3345                 :      795400 : gfc_type_for_size (unsigned bits, int unsignedp)
    3346                 :             : {
    3347                 :      795400 :   if (!unsignedp)
    3348                 :             :     {
    3349                 :             :       int i;
    3350                 :      346932 :       for (i = 0; i <= MAX_INT_KINDS; ++i)
    3351                 :             :         {
    3352                 :      346932 :           tree type = gfc_integer_types[i];
    3353                 :      346932 :           if (type && bits == TYPE_PRECISION (type))
    3354                 :       94249 :             return type;
    3355                 :             :         }
    3356                 :             : 
    3357                 :             :       /* Handle TImode as a special case because it is used by some backends
    3358                 :             :          (e.g. ARM) even though it is not available for normal use.  */
    3359                 :             : #if HOST_BITS_PER_WIDE_INT >= 64
    3360                 :           0 :       if (bits == TYPE_PRECISION (intTI_type_node))
    3361                 :             :         return intTI_type_node;
    3362                 :             : #endif
    3363                 :             : 
    3364                 :           0 :       if (bits <= TYPE_PRECISION (intQI_type_node))
    3365                 :             :         return intQI_type_node;
    3366                 :           0 :       if (bits <= TYPE_PRECISION (intHI_type_node))
    3367                 :             :         return intHI_type_node;
    3368                 :           0 :       if (bits <= TYPE_PRECISION (intSI_type_node))
    3369                 :             :         return intSI_type_node;
    3370                 :           0 :       if (bits <= TYPE_PRECISION (intDI_type_node))
    3371                 :             :         return intDI_type_node;
    3372                 :           0 :       if (bits <= TYPE_PRECISION (intTI_type_node))
    3373                 :             :         return intTI_type_node;
    3374                 :             :     }
    3375                 :             :   else
    3376                 :             :     {
    3377                 :      701151 :       if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
    3378                 :             :         return unsigned_intQI_type_node;
    3379                 :      639983 :       if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
    3380                 :             :         return unsigned_intHI_type_node;
    3381                 :      609239 :       if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
    3382                 :             :         return unsigned_intSI_type_node;
    3383                 :      568349 :       if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
    3384                 :             :         return unsigned_intDI_type_node;
    3385                 :       29682 :       if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
    3386                 :             :         return unsigned_intTI_type_node;
    3387                 :             :     }
    3388                 :             : 
    3389                 :             :   return NULL_TREE;
    3390                 :             : }
    3391                 :             : 
    3392                 :             : /* Return a data type that has machine mode MODE.  If the mode is an
    3393                 :             :    integer, then UNSIGNEDP selects between signed and unsigned types.  */
    3394                 :             : 
    3395                 :             : tree
    3396                 :      734273 : gfc_type_for_mode (machine_mode mode, int unsignedp)
    3397                 :             : {
    3398                 :      734273 :   int i;
    3399                 :      734273 :   tree *base;
    3400                 :      734273 :   scalar_int_mode int_mode;
    3401                 :             : 
    3402                 :      734273 :   if (GET_MODE_CLASS (mode) == MODE_FLOAT)
    3403                 :             :     base = gfc_real_types;
    3404                 :      727454 :   else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
    3405                 :             :     base = gfc_complex_types;
    3406                 :      549644 :   else if (is_a <scalar_int_mode> (mode, &int_mode))
    3407                 :             :     {
    3408                 :      548421 :       tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp);
    3409                 :      548421 :       return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
    3410                 :             :     }
    3411                 :        1223 :   else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
    3412                 :        1223 :            && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    3413                 :             :     {
    3414                 :           0 :       unsigned int elem_bits = vector_element_size (GET_MODE_PRECISION (mode),
    3415                 :             :                                                     GET_MODE_NUNITS (mode));
    3416                 :           0 :       tree bool_type = build_nonstandard_boolean_type (elem_bits);
    3417                 :           0 :       return build_vector_type_for_mode (bool_type, mode);
    3418                 :             :     }
    3419                 :          35 :   else if (VECTOR_MODE_P (mode)
    3420                 :        2443 :            && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    3421                 :             :     {
    3422                 :        1220 :       machine_mode inner_mode = GET_MODE_INNER (mode);
    3423                 :        1220 :       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
    3424                 :        1220 :       if (inner_type != NULL_TREE)
    3425                 :        1220 :         return build_vector_type_for_mode (inner_type, mode);
    3426                 :             :       return NULL_TREE;
    3427                 :             :     }
    3428                 :             :   else
    3429                 :           3 :     return NULL_TREE;
    3430                 :             : 
    3431                 :      721813 :   for (i = 0; i <= MAX_REAL_KINDS; ++i)
    3432                 :             :     {
    3433                 :      662863 :       tree type = base[i];
    3434                 :      662863 :       if (type && mode == TYPE_MODE (type))
    3435                 :      125679 :         return type;
    3436                 :             :     }
    3437                 :             : 
    3438                 :             :   return NULL_TREE;
    3439                 :             : }
    3440                 :             : 
    3441                 :             : /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
    3442                 :             :    in that case.  */
    3443                 :             : 
    3444                 :             : bool
    3445                 :      341069 : gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
    3446                 :             : {
    3447                 :      341069 :   int rank, dim;
    3448                 :      341069 :   bool indirect = false;
    3449                 :      341069 :   tree etype, ptype, t, base_decl;
    3450                 :      341069 :   tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
    3451                 :      341069 :   tree lower_suboff, upper_suboff, stride_suboff;
    3452                 :      341069 :   tree dtype, field, rank_off;
    3453                 :             : 
    3454                 :      341069 :   if (! GFC_DESCRIPTOR_TYPE_P (type))
    3455                 :             :     {
    3456                 :      218869 :       if (! POINTER_TYPE_P (type))
    3457                 :             :         return false;
    3458                 :      136398 :       type = TREE_TYPE (type);
    3459                 :      136398 :       if (! GFC_DESCRIPTOR_TYPE_P (type))
    3460                 :             :         return false;
    3461                 :             :       indirect = true;
    3462                 :             :     }
    3463                 :             : 
    3464                 :      239976 :   rank = GFC_TYPE_ARRAY_RANK (type);
    3465                 :      239976 :   if (rank >= (int) (ARRAY_SIZE (info->dimen)))
    3466                 :             :     return false;
    3467                 :             : 
    3468                 :      239976 :   etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
    3469                 :      239976 :   gcc_assert (POINTER_TYPE_P (etype));
    3470                 :      239976 :   etype = TREE_TYPE (etype);
    3471                 :             : 
    3472                 :             :   /* If the type is not a scalar coarray.  */
    3473                 :      239976 :   if (TREE_CODE (etype) == ARRAY_TYPE)
    3474                 :      239952 :     etype = TREE_TYPE (etype);
    3475                 :             : 
    3476                 :             :   /* Can't handle variable sized elements yet.  */
    3477                 :      239976 :   if (int_size_in_bytes (etype) <= 0)
    3478                 :             :     return false;
    3479                 :             :   /* Nor non-constant lower bounds in assumed shape arrays.  */
    3480                 :      223496 :   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
    3481                 :      223496 :       || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    3482                 :             :     {
    3483                 :       64879 :       for (dim = 0; dim < rank; dim++)
    3484                 :       39287 :         if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
    3485                 :       39287 :             || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
    3486                 :             :           return false;
    3487                 :             :     }
    3488                 :             : 
    3489                 :      223414 :   memset (info, '\0', sizeof (*info));
    3490                 :      223414 :   info->ndimensions = rank;
    3491                 :      223414 :   info->ordering = array_descr_ordering_column_major;
    3492                 :      223414 :   info->element_type = etype;
    3493                 :      223414 :   ptype = build_pointer_type (gfc_array_index_type);
    3494                 :      223414 :   base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
    3495                 :      223414 :   if (!base_decl)
    3496                 :             :     {
    3497                 :      325906 :       base_decl = build_debug_expr_decl (indirect
    3498                 :      108629 :                                          ? build_pointer_type (ptype) : ptype);
    3499                 :      217277 :       GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
    3500                 :             :     }
    3501                 :      223414 :   info->base_decl = base_decl;
    3502                 :      223414 :   if (indirect)
    3503                 :      109943 :     base_decl = build1 (INDIRECT_REF, ptype, base_decl);
    3504                 :             : 
    3505                 :      223414 :   gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
    3506                 :             :                                        &dim_off, &dim_size, &stride_suboff,
    3507                 :             :                                        &lower_suboff, &upper_suboff);
    3508                 :             : 
    3509                 :      223414 :   t = fold_build_pointer_plus (base_decl, span_off);
    3510                 :      223414 :   elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3511                 :             : 
    3512                 :      223414 :   t = base_decl;
    3513                 :      223414 :   if (!integer_zerop (data_off))
    3514                 :           0 :     t = fold_build_pointer_plus (t, data_off);
    3515                 :      223414 :   t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
    3516                 :      223414 :   info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
    3517                 :      223414 :   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
    3518                 :       20139 :     info->allocated = build2 (NE_EXPR, logical_type_node,
    3519                 :             :                               info->data_location, null_pointer_node);
    3520                 :      203275 :   else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
    3521                 :      203275 :            || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
    3522                 :       14202 :     info->associated = build2 (NE_EXPR, logical_type_node,
    3523                 :             :                                info->data_location, null_pointer_node);
    3524                 :      223414 :   if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
    3525                 :      215549 :        || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
    3526                 :      227844 :       && dwarf_version >= 5)
    3527                 :             :     {
    3528                 :       12295 :       rank = 1;
    3529                 :       12295 :       info->ndimensions = 1;
    3530                 :       12295 :       t = base_decl;
    3531                 :       12295 :       if (!integer_zerop (dtype_off))
    3532                 :       12295 :         t = fold_build_pointer_plus (t, dtype_off);
    3533                 :       12295 :       dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
    3534                 :       12295 :       field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
    3535                 :       12295 :       rank_off = byte_position (field);
    3536                 :       12295 :       if (!integer_zerop (dtype_off))
    3537                 :       12295 :         t = fold_build_pointer_plus (t, rank_off);
    3538                 :             : 
    3539                 :       12295 :       t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t);
    3540                 :       12295 :       t = build1 (INDIRECT_REF, TREE_TYPE (field), t);
    3541                 :       12295 :       info->rank = t;
    3542                 :       12295 :       t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
    3543                 :       12295 :       t = size_binop (MULT_EXPR, t, dim_size);
    3544                 :       12295 :       dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
    3545                 :             :     }
    3546                 :             : 
    3547                 :      542167 :   for (dim = 0; dim < rank; dim++)
    3548                 :             :     {
    3549                 :      318753 :       t = fold_build_pointer_plus (base_decl,
    3550                 :             :                                    size_binop (PLUS_EXPR,
    3551                 :             :                                                dim_off, lower_suboff));
    3552                 :      318753 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3553                 :      318753 :       info->dimen[dim].lower_bound = t;
    3554                 :      318753 :       t = fold_build_pointer_plus (base_decl,
    3555                 :             :                                    size_binop (PLUS_EXPR,
    3556                 :             :                                                dim_off, upper_suboff));
    3557                 :      318753 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3558                 :      318753 :       info->dimen[dim].upper_bound = t;
    3559                 :      318753 :       if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
    3560                 :      318753 :           || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    3561                 :             :         {
    3562                 :             :           /* Assumed shape arrays have known lower bounds.  */
    3563                 :       39205 :           info->dimen[dim].upper_bound
    3564                 :       39205 :             = build2 (MINUS_EXPR, gfc_array_index_type,
    3565                 :             :                       info->dimen[dim].upper_bound,
    3566                 :             :                       info->dimen[dim].lower_bound);
    3567                 :       39205 :           info->dimen[dim].lower_bound
    3568                 :       39205 :             = fold_convert (gfc_array_index_type,
    3569                 :             :                             GFC_TYPE_ARRAY_LBOUND (type, dim));
    3570                 :       39205 :           info->dimen[dim].upper_bound
    3571                 :       39205 :             = build2 (PLUS_EXPR, gfc_array_index_type,
    3572                 :             :                       info->dimen[dim].lower_bound,
    3573                 :             :                       info->dimen[dim].upper_bound);
    3574                 :             :         }
    3575                 :      318753 :       t = fold_build_pointer_plus (base_decl,
    3576                 :             :                                    size_binop (PLUS_EXPR,
    3577                 :             :                                                dim_off, stride_suboff));
    3578                 :      318753 :       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
    3579                 :      318753 :       t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
    3580                 :      318753 :       info->dimen[dim].stride = t;
    3581                 :      318753 :       if (dim + 1 < rank)
    3582                 :       95362 :         dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
    3583                 :             :     }
    3584                 :             : 
    3585                 :             :   return true;
    3586                 :             : }
    3587                 :             : 
    3588                 :             : 
    3589                 :             : /* Create a type to handle vector subscripts for coarray library calls. It
    3590                 :             :    has the form:
    3591                 :             :      struct caf_vector_t {
    3592                 :             :        size_t nvec;  // size of the vector
    3593                 :             :        union {
    3594                 :             :          struct {
    3595                 :             :            void *vector;
    3596                 :             :            int kind;
    3597                 :             :          } v;
    3598                 :             :          struct {
    3599                 :             :            ptrdiff_t lower_bound;
    3600                 :             :            ptrdiff_t upper_bound;
    3601                 :             :            ptrdiff_t stride;
    3602                 :             :          } triplet;
    3603                 :             :        } u;
    3604                 :             :      }
    3605                 :             :    where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
    3606                 :             :    size in case of DIMEN_VECTOR, where kind is the integer type of the vector.  */
    3607                 :             : 
    3608                 :             : tree
    3609                 :           0 : gfc_get_caf_vector_type (int dim)
    3610                 :             : {
    3611                 :           0 :   static tree vector_types[GFC_MAX_DIMENSIONS];
    3612                 :           0 :   static tree vec_type = NULL_TREE;
    3613                 :           0 :   tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
    3614                 :             : 
    3615                 :           0 :   if (vector_types[dim-1] != NULL_TREE)
    3616                 :             :     return vector_types[dim-1];
    3617                 :             : 
    3618                 :           0 :   if (vec_type == NULL_TREE)
    3619                 :             :     {
    3620                 :           0 :       chain = 0;
    3621                 :           0 :       vect_struct_type = make_node (RECORD_TYPE);
    3622                 :           0 :       tmp = gfc_add_field_to_struct_1 (vect_struct_type,
    3623                 :             :                                        get_identifier ("vector"),
    3624                 :             :                                        pvoid_type_node, &chain);
    3625                 :           0 :       suppress_warning (tmp);
    3626                 :           0 :       tmp = gfc_add_field_to_struct_1 (vect_struct_type,
    3627                 :             :                                        get_identifier ("kind"),
    3628                 :             :                                        integer_type_node, &chain);
    3629                 :           0 :       suppress_warning (tmp);
    3630                 :           0 :       gfc_finish_type (vect_struct_type);
    3631                 :             : 
    3632                 :           0 :       chain = 0;
    3633                 :           0 :       triplet_struct_type = make_node (RECORD_TYPE);
    3634                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
    3635                 :             :                                        get_identifier ("lower_bound"),
    3636                 :             :                                        gfc_array_index_type, &chain);
    3637                 :           0 :       suppress_warning (tmp);
    3638                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
    3639                 :             :                                        get_identifier ("upper_bound"),
    3640                 :             :                                        gfc_array_index_type, &chain);
    3641                 :           0 :       suppress_warning (tmp);
    3642                 :           0 :       tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
    3643                 :             :                                        gfc_array_index_type, &chain);
    3644                 :           0 :       suppress_warning (tmp);
    3645                 :           0 :       gfc_finish_type (triplet_struct_type);
    3646                 :             : 
    3647                 :           0 :       chain = 0;
    3648                 :           0 :       union_type = make_node (UNION_TYPE);
    3649                 :           0 :       tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
    3650                 :             :                                        vect_struct_type, &chain);
    3651                 :           0 :       suppress_warning (tmp);
    3652                 :           0 :       tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
    3653                 :             :                                        triplet_struct_type, &chain);
    3654                 :           0 :       suppress_warning (tmp);
    3655                 :           0 :       gfc_finish_type (union_type);
    3656                 :             : 
    3657                 :           0 :       chain = 0;
    3658                 :           0 :       vec_type = make_node (RECORD_TYPE);
    3659                 :           0 :       tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
    3660                 :             :                                        size_type_node, &chain);
    3661                 :           0 :       suppress_warning (tmp);
    3662                 :           0 :       tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
    3663                 :             :                                        union_type, &chain);
    3664                 :           0 :       suppress_warning (tmp);
    3665                 :           0 :       gfc_finish_type (vec_type);
    3666                 :           0 :       TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
    3667                 :             :     }
    3668                 :             : 
    3669                 :           0 :   tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3670                 :             :                           gfc_rank_cst[dim-1]);
    3671                 :           0 :   vector_types[dim-1] = build_array_type (vec_type, tmp);
    3672                 :           0 :   return vector_types[dim-1];
    3673                 :             : }
    3674                 :             : 
    3675                 :             : 
    3676                 :             : tree
    3677                 :        1741 : gfc_get_caf_reference_type ()
    3678                 :             : {
    3679                 :        1741 :   static tree reference_type = NULL_TREE;
    3680                 :        1741 :   tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
    3681                 :             :       a_struct_type, u_union_type, tmp, *chain;
    3682                 :             : 
    3683                 :        1741 :   if (reference_type != NULL_TREE)
    3684                 :             :     return reference_type;
    3685                 :             : 
    3686                 :          82 :   chain = 0;
    3687                 :          82 :   c_struct_type = make_node (RECORD_TYPE);
    3688                 :          82 :   tmp = gfc_add_field_to_struct_1 (c_struct_type,
    3689                 :             :                                    get_identifier ("offset"),
    3690                 :             :                                    gfc_array_index_type, &chain);
    3691                 :          82 :   suppress_warning (tmp);
    3692                 :          82 :   tmp = gfc_add_field_to_struct_1 (c_struct_type,
    3693                 :             :                                    get_identifier ("caf_token_offset"),
    3694                 :             :                                    gfc_array_index_type, &chain);
    3695                 :          82 :   suppress_warning (tmp);
    3696                 :          82 :   gfc_finish_type (c_struct_type);
    3697                 :             : 
    3698                 :          82 :   chain = 0;
    3699                 :          82 :   s_struct_type = make_node (RECORD_TYPE);
    3700                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3701                 :             :                                    get_identifier ("start"),
    3702                 :             :                                    gfc_array_index_type, &chain);
    3703                 :          82 :   suppress_warning (tmp);
    3704                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3705                 :             :                                    get_identifier ("end"),
    3706                 :             :                                    gfc_array_index_type, &chain);
    3707                 :          82 :   suppress_warning (tmp);
    3708                 :          82 :   tmp = gfc_add_field_to_struct_1 (s_struct_type,
    3709                 :             :                                    get_identifier ("stride"),
    3710                 :             :                                    gfc_array_index_type, &chain);
    3711                 :          82 :   suppress_warning (tmp);
    3712                 :          82 :   gfc_finish_type (s_struct_type);
    3713                 :             : 
    3714                 :          82 :   chain = 0;
    3715                 :          82 :   v_struct_type = make_node (RECORD_TYPE);
    3716                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3717                 :             :                                    get_identifier ("vector"),
    3718                 :             :                                    pvoid_type_node, &chain);
    3719                 :          82 :   suppress_warning (tmp);
    3720                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3721                 :             :                                    get_identifier ("nvec"),
    3722                 :             :                                    size_type_node, &chain);
    3723                 :          82 :   suppress_warning (tmp);
    3724                 :          82 :   tmp = gfc_add_field_to_struct_1 (v_struct_type,
    3725                 :             :                                    get_identifier ("kind"),
    3726                 :             :                                    integer_type_node, &chain);
    3727                 :          82 :   suppress_warning (tmp);
    3728                 :          82 :   gfc_finish_type (v_struct_type);
    3729                 :             : 
    3730                 :          82 :   chain = 0;
    3731                 :          82 :   union_type = make_node (UNION_TYPE);
    3732                 :          82 :   tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
    3733                 :             :                                    s_struct_type, &chain);
    3734                 :          82 :   suppress_warning (tmp);
    3735                 :          82 :   tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
    3736                 :             :                                    v_struct_type, &chain);
    3737                 :          82 :   suppress_warning (tmp);
    3738                 :          82 :   gfc_finish_type (union_type);
    3739                 :             : 
    3740                 :          82 :   tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3741                 :             :                           gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
    3742                 :          82 :   dim_union_type = build_array_type (union_type, tmp);
    3743                 :             : 
    3744                 :          82 :   chain = 0;
    3745                 :          82 :   a_struct_type = make_node (RECORD_TYPE);
    3746                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
    3747                 :             :                 build_array_type (unsigned_char_type_node,
    3748                 :             :                                   build_range_type (gfc_array_index_type,
    3749                 :             :                                                     gfc_index_zero_node,
    3750                 :             :                                          gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
    3751                 :             :                 &chain);
    3752                 :          82 :   suppress_warning (tmp);
    3753                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type,
    3754                 :             :                                    get_identifier ("static_array_type"),
    3755                 :             :                                    integer_type_node, &chain);
    3756                 :          82 :   suppress_warning (tmp);
    3757                 :          82 :   tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
    3758                 :             :                                    dim_union_type, &chain);
    3759                 :          82 :   suppress_warning (tmp);
    3760                 :          82 :   gfc_finish_type (a_struct_type);
    3761                 :             : 
    3762                 :          82 :   chain = 0;
    3763                 :          82 :   u_union_type = make_node (UNION_TYPE);
    3764                 :          82 :   tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
    3765                 :             :                                    c_struct_type, &chain);
    3766                 :          82 :   suppress_warning (tmp);
    3767                 :          82 :   tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
    3768                 :             :                                    a_struct_type, &chain);
    3769                 :          82 :   suppress_warning (tmp);
    3770                 :          82 :   gfc_finish_type (u_union_type);
    3771                 :             : 
    3772                 :          82 :   chain = 0;
    3773                 :          82 :   reference_type = make_node (RECORD_TYPE);
    3774                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
    3775                 :             :                                    build_pointer_type (reference_type), &chain);
    3776                 :          82 :   suppress_warning (tmp);
    3777                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
    3778                 :             :                                    integer_type_node, &chain);
    3779                 :          82 :   suppress_warning (tmp);
    3780                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
    3781                 :             :                                    size_type_node, &chain);
    3782                 :          82 :   suppress_warning (tmp);
    3783                 :          82 :   tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
    3784                 :             :                                    u_union_type, &chain);
    3785                 :          82 :   suppress_warning (tmp);
    3786                 :          82 :   gfc_finish_type (reference_type);
    3787                 :          82 :   TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
    3788                 :             : 
    3789                 :          82 :   return reference_type;
    3790                 :             : }
    3791                 :             : 
    3792                 :             : static tree
    3793                 :        1327 : gfc_get_cfi_dim_type ()
    3794                 :             : {
    3795                 :        1327 :   static tree CFI_dim_t = NULL;
    3796                 :             : 
    3797                 :        1327 :   if (CFI_dim_t)
    3798                 :             :     return CFI_dim_t;
    3799                 :             : 
    3800                 :         629 :   CFI_dim_t = make_node (RECORD_TYPE);
    3801                 :         629 :   TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
    3802                 :         629 :   TYPE_NAMELESS (CFI_dim_t) = 1;
    3803                 :         629 :   tree field;
    3804                 :         629 :   tree *chain = NULL;
    3805                 :         629 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
    3806                 :             :                                      gfc_array_index_type, &chain);
    3807                 :         629 :   suppress_warning (field);
    3808                 :         629 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
    3809                 :             :                                      gfc_array_index_type, &chain);
    3810                 :         629 :   suppress_warning (field);
    3811                 :         629 :   field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
    3812                 :             :                                      gfc_array_index_type, &chain);
    3813                 :         629 :   suppress_warning (field);
    3814                 :         629 :   gfc_finish_type (CFI_dim_t);
    3815                 :         629 :   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
    3816                 :         629 :   return CFI_dim_t;
    3817                 :             : }
    3818                 :             : 
    3819                 :             : 
    3820                 :             : /* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
    3821                 :             :    otherwise dim[dimen] is used.  */
    3822                 :             : 
    3823                 :             : tree
    3824                 :       12476 : gfc_get_cfi_type (int dimen, bool restricted)
    3825                 :             : {
    3826                 :       12476 :   gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
    3827                 :             : 
    3828                 :       12476 :   int idx = 2*(dimen + 1) + restricted;
    3829                 :             : 
    3830                 :       12476 :   if (gfc_cfi_descriptor_base[idx])
    3831                 :             :     return gfc_cfi_descriptor_base[idx];
    3832                 :             : 
    3833                 :             :   /* Build the type node.  */
    3834                 :        1504 :   tree CFI_cdesc_t = make_node (RECORD_TYPE);
    3835                 :        1504 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    3836                 :        1504 :   if (dimen != -1)
    3837                 :         955 :     sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
    3838                 :        1504 :   TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
    3839                 :        1504 :   TYPE_NAMELESS (CFI_cdesc_t) = 1;
    3840                 :             : 
    3841                 :        1504 :   tree field;
    3842                 :        1504 :   tree *chain = NULL;
    3843                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
    3844                 :             :                                      (restricted ? prvoid_type_node
    3845                 :             :                                                  : ptr_type_node), &chain);
    3846                 :        1504 :   suppress_warning (field);
    3847                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
    3848                 :             :                                      size_type_node, &chain);
    3849                 :        1504 :   suppress_warning (field);
    3850                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
    3851                 :             :                                      integer_type_node, &chain);
    3852                 :        1504 :   suppress_warning (field);
    3853                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
    3854                 :             :                                      signed_char_type_node, &chain);
    3855                 :        1504 :   suppress_warning (field);
    3856                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
    3857                 :             :                                      signed_char_type_node, &chain);
    3858                 :        1504 :   suppress_warning (field);
    3859                 :        1504 :   field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
    3860                 :             :                                      get_typenode_from_name (INT16_TYPE),
    3861                 :             :                                      &chain);
    3862                 :        1504 :   suppress_warning (field);
    3863                 :             : 
    3864                 :        1504 :   if (dimen != 0)
    3865                 :             :     {
    3866                 :        1327 :       tree range = NULL_TREE;
    3867                 :        1327 :       if (dimen > 0)
    3868                 :         778 :         range = gfc_rank_cst[dimen - 1];
    3869                 :        1327 :       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
    3870                 :             :                                 range);
    3871                 :        1327 :       tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
    3872                 :        1327 :       field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
    3873                 :             :                                          CFI_dim_t, &chain);
    3874                 :        1327 :       suppress_warning (field);
    3875                 :             :     }
    3876                 :             : 
    3877                 :        1504 :   TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
    3878                 :        1504 :   gfc_finish_type (CFI_cdesc_t);
    3879                 :        1504 :   gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
    3880                 :        1504 :   return CFI_cdesc_t;
    3881                 :             : }
    3882                 :             : 
    3883                 :             : #include "gt-fortran-trans-types.h"
        

Generated by: LCOV version 2.0-1

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