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

Generated by: LCOV version 1.0

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