gcc/fortran/trans-types.c

   1 /* Backend support for Fortran 95 basic types and derived types.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-types.c -- gfortran backend types */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tree.h"
  29 #include "langhooks.h"
  30 #include "tm.h"
  31 #include "target.h"
  32 #include "ggc.h"
  33 #include "toplev.h"
  34 #include "gfortran.h"
  35 #include "trans.h"
  36 #include "trans-types.h"
  37 #include "trans-const.h"
  38 #include "real.h"
  39 #include "flags.h"
  40 #include "dwarf2out.h"
  41 \f
  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 static tree gfc_get_derived_type (gfc_symbol * derived);
  57
  58 tree gfc_array_index_type;
  59 tree gfc_array_range_type;
  60 tree gfc_character1_type_node;
  61 tree pvoid_type_node;
  62 tree ppvoid_type_node;
  63 tree pchar_type_node;
  64 tree pfunc_type_node;
  65
  66 tree gfc_charlen_type_node;
  67
  68 static GTY(()) tree gfc_desc_dim_type;
  69 static GTY(()) tree gfc_max_array_element_size;
  70 static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
  71
  72 /* Arrays for all integral and real kinds.  We'll fill this in at runtime
  73    after the target has a chance to process command-line options.  */
  74
  75 #define MAX_INT_KINDS 5
  76 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
  77 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
  78 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
  79 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
  80
  81 #define MAX_REAL_KINDS 5
  82 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
  83 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
  84 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
  85
  86 #define MAX_CHARACTER_KINDS 2
  87 gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
  88 static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
  89 static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
  90
  91
  92 /* The integer kind to use for array indices.  This will be set to the
  93    proper value based on target information from the backend.  */
  94
  95 int gfc_index_integer_kind;
  96
  97 /* The default kinds of the various types.  */
  98
  99 int gfc_default_integer_kind;
 100 int gfc_max_integer_kind;
 101 int gfc_default_real_kind;
 102 int gfc_default_double_kind;
 103 int gfc_default_character_kind;
 104 int gfc_default_logical_kind;
 105 int gfc_default_complex_kind;
 106 int gfc_c_int_kind;
 107
 108 /* The kind size used for record offsets. If the target system supports
 109    kind=8, this will be set to 8, otherwise it is set to 4.  */
 110 int gfc_intio_kind;
 111
 112 /* The integer kind used to store character lengths.  */
 113 int gfc_charlen_int_kind;
 114
 115 /* The size of the numeric storage unit and character storage unit.  */
 116 int gfc_numeric_storage_size;
 117 int gfc_character_storage_size;
 118
 119
 120 gfc_try
 121 gfc_check_any_c_kind (gfc_typespec *ts)
 122 {
 123   int i;
 124
 125   for (i = 0; i < ISOCBINDING_NUMBER; i++)
 126     {
 127       /* Check for any C interoperable kind for the given type/kind in ts.
 128          This can be used after verify_c_interop to make sure that the
 129          Fortran kind being used exists in at least some form for C.  */
 130       if (c_interop_kinds_table[i].f90_type == ts->type &&
 131           c_interop_kinds_table[i].value == ts->kind)
 132         return SUCCESS;
 133     }
 134
 135   return FAILURE;
 136 }
 137
 138
 139 static int
 140 get_real_kind_from_node (tree type)
 141 {
 142   int i;
 143
 144   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
 145     if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
 146       return gfc_real_kinds[i].kind;
 147
 148   return -4;
 149 }
 150
 151 static int
 152 get_int_kind_from_node (tree type)
 153 {
 154   int i;
 155
 156   if (!type)
 157     return -2;
 158
 159   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 160     if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
 161       return gfc_integer_kinds[i].kind;
 162
 163   return -1;
 164 }
 165
 166 /* Return a typenode for the "standard" C type with a given name.  */
 167 static tree
 168 get_typenode_from_name (const char *name)
 169 {
 170   if (name == NULL || *name == '\0')
 171     return NULL_TREE;
 172
 173   if (strcmp (name, "char") == 0)
 174     return char_type_node;
 175   if (strcmp (name, "unsigned char") == 0)
 176     return unsigned_char_type_node;
 177   if (strcmp (name, "signed char") == 0)
 178     return signed_char_type_node;
 179
 180   if (strcmp (name, "short int") == 0)
 181     return short_integer_type_node;
 182   if (strcmp (name, "short unsigned int") == 0)
 183     return short_unsigned_type_node;
 184
 185   if (strcmp (name, "int") == 0)
 186     return integer_type_node;
 187   if (strcmp (name, "unsigned int") == 0)
 188     return unsigned_type_node;
 189
 190   if (strcmp (name, "long int") == 0)
 191     return long_integer_type_node;
 192   if (strcmp (name, "long unsigned int") == 0)
 193     return long_unsigned_type_node;
 194
 195   if (strcmp (name, "long long int") == 0)
 196     return long_long_integer_type_node;
 197   if (strcmp (name, "long long unsigned int") == 0)
 198     return long_long_unsigned_type_node;
 199
 200   gcc_unreachable ();
 201 }
 202
 203 static int
 204 get_int_kind_from_name (const char *name)
 205 {
 206   return get_int_kind_from_node (get_typenode_from_name (name));
 207 }
 208
 209
 210 /* Get the kind number corresponding to an integer of given size,
 211    following the required return values for ISO_FORTRAN_ENV INT* constants:
 212    -2 is returned if we support a kind of larger size, -1 otherwise.  */
 213 int
 214 gfc_get_int_kind_from_width_isofortranenv (int size)
 215 {
 216   int i;
 217
 218   /* Look for a kind with matching storage size.  */
 219   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 220     if (gfc_integer_kinds[i].bit_size == size)
 221       return gfc_integer_kinds[i].kind;
 222
 223   /* Look for a kind with larger storage size.  */
 224   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 225     if (gfc_integer_kinds[i].bit_size > size)
 226       return -2;
 227
 228   return -1;
 229 }
 230
 231 /* Get the kind number corresponding to a real of given storage size,
 232    following the required return values for ISO_FORTRAN_ENV REAL* constants:
 233    -2 is returned if we support a kind of larger size, -1 otherwise.  */
 234 int
 235 gfc_get_real_kind_from_width_isofortranenv (int size)
 236 {
 237   int i;
 238
 239   size /= 8;
 240
 241   /* Look for a kind with matching storage size.  */
 242   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
 243     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
 244       return gfc_real_kinds[i].kind;
 245
 246   /* Look for a kind with larger storage size.  */
 247   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
 248     if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
 249       return -2;
 250
 251   return -1;
 252 }
 253
 254
 255
 256 static int
 257 get_int_kind_from_width (int size)
 258 {
 259   int i;
 260
 261   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 262     if (gfc_integer_kinds[i].bit_size == size)
 263       return gfc_integer_kinds[i].kind;
 264
 265   return -2;
 266 }
 267
 268 static int
 269 get_int_kind_from_minimal_width (int size)
 270 {
 271   int i;
 272
 273   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 274     if (gfc_integer_kinds[i].bit_size >= size)
 275       return gfc_integer_kinds[i].kind;
 276
 277   return -2;
 278 }
 279
 280
 281 /* Generate the CInteropKind_t objects for the C interoperable
 282    kinds.  */
 283
 284 static
 285 void init_c_interop_kinds (void)
 286 {
 287   int i;
 288
 289   /* init all pointers in the list to NULL */
 290   for (i = 0; i < ISOCBINDING_NUMBER; i++)
 291     {
 292       /* Initialize the name and value fields.  */
 293       c_interop_kinds_table[i].name[0] = '\0';
 294       c_interop_kinds_table[i].value = -100;
 295       c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
 296     }
 297
 298 #define NAMED_INTCST(a,b,c,d) \
 299   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 300   c_interop_kinds_table[a].f90_type = BT_INTEGER; \
 301   c_interop_kinds_table[a].value = c;
 302 #define NAMED_REALCST(a,b,c) \
 303   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 304   c_interop_kinds_table[a].f90_type = BT_REAL; \
 305   c_interop_kinds_table[a].value = c;
 306 #define NAMED_CMPXCST(a,b,c) \
 307   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 308   c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
 309   c_interop_kinds_table[a].value = c;
 310 #define NAMED_LOGCST(a,b,c) \
 311   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 312   c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
 313   c_interop_kinds_table[a].value = c;
 314 #define NAMED_CHARKNDCST(a,b,c) \
 315   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 316   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
 317   c_interop_kinds_table[a].value = c;
 318 #define NAMED_CHARCST(a,b,c) \
 319   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 320   c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
 321   c_interop_kinds_table[a].value = c;
 322 #define DERIVED_TYPE(a,b,c) \
 323   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 324   c_interop_kinds_table[a].f90_type = BT_DERIVED; \
 325   c_interop_kinds_table[a].value = c;
 326 #define PROCEDURE(a,b) \
 327   strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
 328   c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
 329   c_interop_kinds_table[a].value = 0;
 330 #include "iso-c-binding.def"
 331 }
 332
 333
 334 /* Query the target to determine which machine modes are available for
 335    computation.  Choose KIND numbers for them.  */
 336
 337 void
 338 gfc_init_kinds (void)
 339 {
 340   unsigned int mode;
 341   int i_index, r_index, kind;
 342   bool saw_i4 = false, saw_i8 = false;
 343   bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
 344
 345   for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
 346     {
 347       int kind, bitsize;
 348
 349       if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
 350         continue;
 351
 352       /* The middle end doesn't support constants larger than 2*HWI.
 353          Perhaps the target hook shouldn't have accepted these either,
 354          but just to be safe...  */
 355       bitsize = GET_MODE_BITSIZE (mode);
 356       if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
 357         continue;
 358
 359       gcc_assert (i_index != MAX_INT_KINDS);
 360
 361       /* Let the kind equal the bit size divided by 8.  This insulates the
 362          programmer from the underlying byte size.  */
 363       kind = bitsize / 8;
 364
 365       if (kind == 4)
 366         saw_i4 = true;
 367       if (kind == 8)
 368         saw_i8 = true;
 369
 370       gfc_integer_kinds[i_index].kind = kind;
 371       gfc_integer_kinds[i_index].radix = 2;
 372       gfc_integer_kinds[i_index].digits = bitsize - 1;
 373       gfc_integer_kinds[i_index].bit_size = bitsize;
 374
 375       gfc_logical_kinds[i_index].kind = kind;
 376       gfc_logical_kinds[i_index].bit_size = bitsize;
 377
 378       i_index += 1;
 379     }
 380
 381   /* Set the kind used to match GFC_INT_IO in libgfortran.  This is
 382      used for large file access.  */
 383
 384   if (saw_i8)
 385     gfc_intio_kind = 8;
 386   else
 387     gfc_intio_kind = 4;
 388
 389   /* If we do not at least have kind = 4, everything is pointless.  */
 390   gcc_assert(saw_i4);
 391
 392   /* Set the maximum integer kind.  Used with at least BOZ constants.  */
 393   gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
 394
 395   for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
 396     {
 397       const struct real_format *fmt =
 398         REAL_MODE_FORMAT ((enum machine_mode) mode);
 399       int kind;
 400
 401       if (fmt == NULL)
 402         continue;
 403       if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
 404         continue;
 405
 406       /* Only let float/double/long double go through because the fortran
 407          library assumes these are the only floating point types.  */
 408
 409       if (mode != TYPE_MODE (float_type_node)
 410           && (mode != TYPE_MODE (double_type_node))
 411           && (mode != TYPE_MODE (long_double_type_node)))
 412         continue;
 413
 414       /* Let the kind equal the precision divided by 8, rounding up.  Again,
 415          this insulates the programmer from the underlying byte size.
 416
 417          Also, it effectively deals with IEEE extended formats.  There, the
 418          total size of the type may equal 16, but it's got 6 bytes of padding
 419          and the increased size can get in the way of a real IEEE quad format
 420          which may also be supported by the target.
 421
 422          We round up so as to handle IA-64 __floatreg (RFmode), which is an
 423          82 bit type.  Not to be confused with __float80 (XFmode), which is
 424          an 80 bit type also supported by IA-64.  So XFmode should come out
 425          to be kind=10, and RFmode should come out to be kind=11.  Egads.  */
 426
 427       kind = (GET_MODE_PRECISION (mode) + 7) / 8;
 428
 429       if (kind == 4)
 430         saw_r4 = true;
 431       if (kind == 8)
 432         saw_r8 = true;
 433       if (kind == 16)
 434         saw_r16 = true;
 435
 436       /* Careful we don't stumble a weird internal mode.  */
 437       gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
 438       /* Or have too many modes for the allocated space.  */
 439       gcc_assert (r_index != MAX_REAL_KINDS);
 440
 441       gfc_real_kinds[r_index].kind = kind;
 442       gfc_real_kinds[r_index].radix = fmt->b;
 443       gfc_real_kinds[r_index].digits = fmt->p;
 444       gfc_real_kinds[r_index].min_exponent = fmt->emin;
 445       gfc_real_kinds[r_index].max_exponent = fmt->emax;
 446       if (fmt->pnan < fmt->p)
 447         /* This is an IBM extended double format (or the MIPS variant)
 448            made up of two IEEE doubles.  The value of the long double is
 449            the sum of the values of the two parts.  The most significant
 450            part is required to be the value of the long double rounded
 451            to the nearest double.  If we use emax of 1024 then we can't
 452            represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
 453            rounding will make the most significant part overflow.  */
 454         gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
 455       gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
 456       r_index += 1;
 457     }
 458
 459   /* Choose the default integer kind.  We choose 4 unless the user
 460      directs us otherwise.  */
 461   if (gfc_option.flag_default_integer)
 462     {
 463       if (!saw_i8)
 464         fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
 465       gfc_default_integer_kind = 8;
 466
 467       /* Even if the user specified that the default integer kind be 8,
 468          the numeric storage size isn't 64.  In this case, a warning will
 469          be issued when NUMERIC_STORAGE_SIZE is used.  */
 470       gfc_numeric_storage_size = 4 * 8;
 471     }
 472   else if (saw_i4)
 473     {
 474       gfc_default_integer_kind = 4;
 475       gfc_numeric_storage_size = 4 * 8;
 476     }
 477   else
 478     {
 479       gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
 480       gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
 481     }
 482
 483   /* Choose the default real kind.  Again, we choose 4 when possible.  */
 484   if (gfc_option.flag_default_real)
 485     {
 486       if (!saw_r8)
 487         fatal_error ("real kind=8 not available for -fdefault-real-8 option");
 488       gfc_default_real_kind = 8;
 489     }
 490   else if (saw_r4)
 491     gfc_default_real_kind = 4;
 492   else
 493     gfc_default_real_kind = gfc_real_kinds[0].kind;
 494
 495   /* Choose the default double kind.  If -fdefault-real and -fdefault-double
 496      are specified, we use kind=8, if it's available.  If -fdefault-real is
 497      specified without -fdefault-double, we use kind=16, if it's available.
 498      Otherwise we do not change anything.  */
 499   if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
 500     fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
 501
 502   if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
 503     gfc_default_double_kind = 8;
 504   else if (gfc_option.flag_default_real && saw_r16)
 505     gfc_default_double_kind = 16;
 506   else if (saw_r4 && saw_r8)
 507     gfc_default_double_kind = 8;
 508   else
 509     {
 510       /* F95 14.6.3.1: A nonpointer scalar object of type double precision
 511          real ... occupies two contiguous numeric storage units.
 512
 513          Therefore we must be supplied a kind twice as large as we chose
 514          for single precision.  There are loopholes, in that double
 515          precision must *occupy* two storage units, though it doesn't have
 516          to *use* two storage units.  Which means that you can make this
 517          kind artificially wide by padding it.  But at present there are
 518          no GCC targets for which a two-word type does not exist, so we
 519          just let gfc_validate_kind abort and tell us if something breaks.  */
 520
 521       gfc_default_double_kind
 522         = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
 523     }
 524
 525   /* The default logical kind is constrained to be the same as the
 526      default integer kind.  Similarly with complex and real.  */
 527   gfc_default_logical_kind = gfc_default_integer_kind;
 528   gfc_default_complex_kind = gfc_default_real_kind;
 529
 530   /* We only have two character kinds: ASCII and UCS-4.
 531      ASCII corresponds to a 8-bit integer type, if one is available.
 532      UCS-4 corresponds to a 32-bit integer type, if one is available. */
 533   i_index = 0;
 534   if ((kind = get_int_kind_from_width (8)) > 0)
 535     {
 536       gfc_character_kinds[i_index].kind = kind;
 537       gfc_character_kinds[i_index].bit_size = 8;
 538       gfc_character_kinds[i_index].name = "ascii";
 539       i_index++;
 540     }
 541   if ((kind = get_int_kind_from_width (32)) > 0)
 542     {
 543       gfc_character_kinds[i_index].kind = kind;
 544       gfc_character_kinds[i_index].bit_size = 32;
 545       gfc_character_kinds[i_index].name = "iso_10646";
 546       i_index++;
 547     }
 548
 549   /* Choose the smallest integer kind for our default character.  */
 550   gfc_default_character_kind = gfc_character_kinds[0].kind;
 551   gfc_character_storage_size = gfc_default_character_kind * 8;
 552
 553   /* Choose the integer kind the same size as "void*" for our index kind.  */
 554   gfc_index_integer_kind = POINTER_SIZE / 8;
 555   /* Pick a kind the same size as the C "int" type.  */
 556   gfc_c_int_kind = INT_TYPE_SIZE / 8;
 557
 558   /* initialize the C interoperable kinds  */
 559   init_c_interop_kinds();
 560 }
 561
 562 /* Make sure that a valid kind is present.  Returns an index into the
 563    associated kinds array, -1 if the kind is not present.  */
 564
 565 static int
 566 validate_integer (int kind)
 567 {
 568   int i;
 569
 570   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
 571     if (gfc_integer_kinds[i].kind == kind)
 572       return i;
 573
 574   return -1;
 575 }
 576
 577 static int
 578 validate_real (int kind)
 579 {
 580   int i;
 581
 582   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
 583     if (gfc_real_kinds[i].kind == kind)
 584       return i;
 585
 586   return -1;
 587 }
 588
 589 static int
 590 validate_logical (int kind)
 591 {
 592   int i;
 593
 594   for (i = 0; gfc_logical_kinds[i].kind; i++)
 595     if (gfc_logical_kinds[i].kind == kind)
 596       return i;
 597
 598   return -1;
 599 }
 600
 601 static int
 602 validate_character (int kind)
 603 {
 604   int i;
 605
 606   for (i = 0; gfc_character_kinds[i].kind; i++)
 607     if (gfc_character_kinds[i].kind == kind)
 608       return i;
 609
 610   return -1;
 611 }
 612
 613 /* Validate a kind given a basic type.  The return value is the same
 614    for the child functions, with -1 indicating nonexistence of the
 615    type.  If MAY_FAIL is false, then -1 is never returned, and we ICE.  */
 616
 617 int
 618 gfc_validate_kind (bt type, int kind, bool may_fail)
 619 {
 620   int rc;
 621
 622   switch (type)
 623     {
 624     case BT_REAL:               /* Fall through */
 625     case BT_COMPLEX:
 626       rc = validate_real (kind);
 627       break;
 628     case BT_INTEGER:
 629       rc = validate_integer (kind);
 630       break;
 631     case BT_LOGICAL:
 632       rc = validate_logical (kind);
 633       break;
 634     case BT_CHARACTER:
 635       rc = validate_character (kind);
 636       break;
 637
 638     default:
 639       gfc_internal_error ("gfc_validate_kind(): Got bad type");
 640     }
 641
 642   if (rc < 0 && !may_fail)
 643     gfc_internal_error ("gfc_validate_kind(): Got bad kind");
 644
 645   return rc;
 646 }
 647
 648
 649 /* Four subroutines of gfc_init_types.  Create type nodes for the given kind.
 650    Reuse common type nodes where possible.  Recognize if the kind matches up
 651    with a C type.  This will be used later in determining which routines may
 652    be scarfed from libm.  */
 653
 654 static tree
 655 gfc_build_int_type (gfc_integer_info *info)
 656 {
 657   int mode_precision = info->bit_size;
 658
 659   if (mode_precision == CHAR_TYPE_SIZE)
 660     info->c_char = 1;
 661   if (mode_precision == SHORT_TYPE_SIZE)
 662     info->c_short = 1;
 663   if (mode_precision == INT_TYPE_SIZE)
 664     info->c_int = 1;
 665   if (mode_precision == LONG_TYPE_SIZE)
 666     info->c_long = 1;
 667   if (mode_precision == LONG_LONG_TYPE_SIZE)
 668     info->c_long_long = 1;
 669
 670   if (TYPE_PRECISION (intQI_type_node) == mode_precision)
 671     return intQI_type_node;
 672   if (TYPE_PRECISION (intHI_type_node) == mode_precision)
 673     return intHI_type_node;
 674   if (TYPE_PRECISION (intSI_type_node) == mode_precision)
 675     return intSI_type_node;
 676   if (TYPE_PRECISION (intDI_type_node) == mode_precision)
 677     return intDI_type_node;
 678   if (TYPE_PRECISION (intTI_type_node) == mode_precision)
 679     return intTI_type_node;
 680
 681   return make_signed_type (mode_precision);
 682 }
 683
 684 tree
 685 gfc_build_uint_type (int size)
 686 {
 687   if (size == CHAR_TYPE_SIZE)
 688     return unsigned_char_type_node;
 689   if (size == SHORT_TYPE_SIZE)
 690     return short_unsigned_type_node;
 691   if (size == INT_TYPE_SIZE)
 692     return unsigned_type_node;
 693   if (size == LONG_TYPE_SIZE)
 694     return long_unsigned_type_node;
 695   if (size == LONG_LONG_TYPE_SIZE)
 696     return long_long_unsigned_type_node;
 697
 698   return make_unsigned_type (size);
 699 }
 700
 701
 702 static tree
 703 gfc_build_real_type (gfc_real_info *info)
 704 {
 705   int mode_precision = info->mode_precision;
 706   tree new_type;
 707
 708   if (mode_precision == FLOAT_TYPE_SIZE)
 709     info->c_float = 1;
 710   if (mode_precision == DOUBLE_TYPE_SIZE)
 711     info->c_double = 1;
 712   if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
 713     info->c_long_double = 1;
 714
 715   if (TYPE_PRECISION (float_type_node) == mode_precision)
 716     return float_type_node;
 717   if (TYPE_PRECISION (double_type_node) == mode_precision)
 718     return double_type_node;
 719   if (TYPE_PRECISION (long_double_type_node) == mode_precision)
 720     return long_double_type_node;
 721
 722   new_type = make_node (REAL_TYPE);
 723   TYPE_PRECISION (new_type) = mode_precision;
 724   layout_type (new_type);
 725   return new_type;
 726 }
 727
 728 static tree
 729 gfc_build_complex_type (tree scalar_type)
 730 {
 731   tree new_type;
 732
 733   if (scalar_type == NULL)
 734     return NULL;
 735   if (scalar_type == float_type_node)
 736     return complex_float_type_node;
 737   if (scalar_type == double_type_node)
 738     return complex_double_type_node;
 739   if (scalar_type == long_double_type_node)
 740     return complex_long_double_type_node;
 741
 742   new_type = make_node (COMPLEX_TYPE);
 743   TREE_TYPE (new_type) = scalar_type;
 744   layout_type (new_type);
 745   return new_type;
 746 }
 747
 748 static tree
 749 gfc_build_logical_type (gfc_logical_info *info)
 750 {
 751   int bit_size = info->bit_size;
 752   tree new_type;
 753
 754   if (bit_size == BOOL_TYPE_SIZE)
 755     {
 756       info->c_bool = 1;
 757       return boolean_type_node;
 758     }
 759
 760   new_type = make_unsigned_type (bit_size);
 761   TREE_SET_CODE (new_type, BOOLEAN_TYPE);
 762   TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
 763   TYPE_PRECISION (new_type) = 1;
 764
 765   return new_type;
 766 }
 767
 768
 769 #if 0
 770 /* Return the bit size of the C "size_t".  */
 771
 772 static unsigned int
 773 c_size_t_size (void)
 774 {
 775 #ifdef SIZE_TYPE
 776   if (strcmp (SIZE_TYPE, "unsigned int") == 0)
 777     return INT_TYPE_SIZE;
 778   if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
 779     return LONG_TYPE_SIZE;
 780   if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
 781     return SHORT_TYPE_SIZE;
 782   gcc_unreachable ();
 783 #else
 784   return LONG_TYPE_SIZE;
 785 #endif
 786 }
 787 #endif
 788
 789 /* Create the backend type nodes. We map them to their
 790    equivalent C type, at least for now.  We also give
 791    names to the types here, and we push them in the
 792    global binding level context.*/
 793
 794 void
 795 gfc_init_types (void)
 796 {
 797   char name_buf[18];
 798   int index;
 799   tree type;
 800   unsigned n;
 801   unsigned HOST_WIDE_INT hi;
 802   unsigned HOST_WIDE_INT lo;
 803
 804   /* Create and name the types.  */
 805 #define PUSH_TYPE(name, node) \
 806   pushdecl (build_decl (input_location, \
 807                         TYPE_DECL, get_identifier (name), node))
 808
 809   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 810     {
 811       type = gfc_build_int_type (&gfc_integer_kinds[index]);
 812       /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
 813       if (TYPE_STRING_FLAG (type))
 814         type = make_signed_type (gfc_integer_kinds[index].bit_size);
 815       gfc_integer_types[index] = type;
 816       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
 817                 gfc_integer_kinds[index].kind);
 818       PUSH_TYPE (name_buf, type);
 819     }
 820
 821   for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
 822     {
 823       type = gfc_build_logical_type (&gfc_logical_kinds[index]);
 824       gfc_logical_types[index] = type;
 825       snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
 826                 gfc_logical_kinds[index].kind);
 827       PUSH_TYPE (name_buf, type);
 828     }
 829
 830   for (index = 0; gfc_real_kinds[index].kind != 0; index++)
 831     {
 832       type = gfc_build_real_type (&gfc_real_kinds[index]);
 833       gfc_real_types[index] = type;
 834       snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
 835                 gfc_real_kinds[index].kind);
 836       PUSH_TYPE (name_buf, type);
 837
 838       type = gfc_build_complex_type (type);
 839       gfc_complex_types[index] = type;
 840       snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
 841                 gfc_real_kinds[index].kind);
 842       PUSH_TYPE (name_buf, type);
 843     }
 844
 845   for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
 846     {
 847       type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
 848       type = build_qualified_type (type, TYPE_UNQUALIFIED);
 849       snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
 850                 gfc_character_kinds[index].kind);
 851       PUSH_TYPE (name_buf, type);
 852       gfc_character_types[index] = type;
 853       gfc_pcharacter_types[index] = build_pointer_type (type);
 854     }
 855   gfc_character1_type_node = gfc_character_types[0];
 856
 857   PUSH_TYPE ("byte", unsigned_char_type_node);
 858   PUSH_TYPE ("void", void_type_node);
 859
 860   /* DBX debugging output gets upset if these aren't set.  */
 861   if (!TYPE_NAME (integer_type_node))
 862     PUSH_TYPE ("c_integer", integer_type_node);
 863   if (!TYPE_NAME (char_type_node))
 864     PUSH_TYPE ("c_char", char_type_node);
 865
 866 #undef PUSH_TYPE
 867
 868   pvoid_type_node = build_pointer_type (void_type_node);
 869   ppvoid_type_node = build_pointer_type (pvoid_type_node);
 870   pchar_type_node = build_pointer_type (gfc_character1_type_node);
 871   pfunc_type_node
 872     = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
 873
 874   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
 875   /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
 876      since this function is called before gfc_init_constants.  */
 877   gfc_array_range_type
 878           = build_range_type (gfc_array_index_type,
 879                               build_int_cst (gfc_array_index_type, 0),
 880                               NULL_TREE);
 881
 882   /* The maximum array element size that can be handled is determined
 883      by the number of bits available to store this field in the array
 884      descriptor.  */
 885
 886   n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
 887   lo = ~ (unsigned HOST_WIDE_INT) 0;
 888   if (n > HOST_BITS_PER_WIDE_INT)
 889     hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
 890   else
 891     hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
 892   gfc_max_array_element_size
 893     = build_int_cst_wide (long_unsigned_type_node, lo, hi);
 894
 895   size_type_node = gfc_array_index_type;
 896
 897   boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
 898   boolean_true_node = build_int_cst (boolean_type_node, 1);
 899   boolean_false_node = build_int_cst (boolean_type_node, 0);
 900
 901   /* ??? Shouldn't this be based on gfc_index_integer_kind or so?  */
 902   gfc_charlen_int_kind = 4;
 903   gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
 904 }
 905
 906 /* Get the type node for the given type and kind.  */
 907
 908 tree
 909 gfc_get_int_type (int kind)
 910 {
 911   int index = gfc_validate_kind (BT_INTEGER, kind, true);
 912   return index < 0 ? 0 : gfc_integer_types[index];
 913 }
 914
 915 tree
 916 gfc_get_real_type (int kind)
 917 {
 918   int index = gfc_validate_kind (BT_REAL, kind, true);
 919   return index < 0 ? 0 : gfc_real_types[index];
 920 }
 921
 922 tree
 923 gfc_get_complex_type (int kind)
 924 {
 925   int index = gfc_validate_kind (BT_COMPLEX, kind, true);
 926   return index < 0 ? 0 : gfc_complex_types[index];
 927 }
 928
 929 tree
 930 gfc_get_logical_type (int kind)
 931 {
 932   int index = gfc_validate_kind (BT_LOGICAL, kind, true);
 933   return index < 0 ? 0 : gfc_logical_types[index];
 934 }
 935
 936 tree
 937 gfc_get_char_type (int kind)
 938 {
 939   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
 940   return index < 0 ? 0 : gfc_character_types[index];
 941 }
 942
 943 tree
 944 gfc_get_pchar_type (int kind)
 945 {
 946   int index = gfc_validate_kind (BT_CHARACTER, kind, true);
 947   return index < 0 ? 0 : gfc_pcharacter_types[index];
 948 }
 949
 950 \f
 951 /* Create a character type with the given kind and length.  */
 952
 953 tree
 954 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
 955 {
 956   tree bounds, type;
 957
 958   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
 959   type = build_array_type (eltype, bounds);
 960   TYPE_STRING_FLAG (type) = 1;
 961
 962   return type;
 963 }
 964
 965 tree
 966 gfc_get_character_type_len (int kind, tree len)
 967 {
 968   gfc_validate_kind (BT_CHARACTER, kind, false);
 969   return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
 970 }
 971
 972
 973 /* Get a type node for a character kind.  */
 974
 975 tree
 976 gfc_get_character_type (int kind, gfc_charlen * cl)
 977 {
 978   tree len;
 979
 980   len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
 981
 982   return gfc_get_character_type_len (kind, len);
 983 }
 984 \f
 985 /* Covert a basic type.  This will be an array for character types.  */
 986
 987 tree
 988 gfc_typenode_for_spec (gfc_typespec * spec)
 989 {
 990   tree basetype;
 991
 992   switch (spec->type)
 993     {
 994     case BT_UNKNOWN:
 995       gcc_unreachable ();
 996
 997     case BT_INTEGER:
 998       /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
 999          has been resolved.  This is done so we can convert C_PTR and
1000          C_FUNPTR to simple variables that get translated to (void *).  */
1001       if (spec->f90_type == BT_VOID)
1002         {
1003           if (spec->u.derived
1004               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1005             basetype = ptr_type_node;
1006           else
1007             basetype = pfunc_type_node;
1008         }
1009       else
1010         basetype = gfc_get_int_type (spec->kind);
1011       break;
1012
1013     case BT_REAL:
1014       basetype = gfc_get_real_type (spec->kind);
1015       break;
1016
1017     case BT_COMPLEX:
1018       basetype = gfc_get_complex_type (spec->kind);
1019       break;
1020
1021     case BT_LOGICAL:
1022       basetype = gfc_get_logical_type (spec->kind);
1023       break;
1024
1025     case BT_CHARACTER:
1026       basetype = gfc_get_character_type (spec->kind, spec->u.cl);
1027       break;
1028
1029     case BT_DERIVED:
1030       basetype = gfc_get_derived_type (spec->u.derived);
1031
1032       /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
1033          type and kind to fit a (void *) and the basetype returned was a
1034          ptr_type_node.  We need to pass up this new information to the
1035          symbol that was declared of type C_PTR or C_FUNPTR.  */
1036       if (spec->u.derived->attr.is_iso_c)
1037         {
1038           spec->type = spec->u.derived->ts.type;
1039           spec->kind = spec->u.derived->ts.kind;
1040           spec->f90_type = spec->u.derived->ts.f90_type;
1041         }
1042       break;
1043     case BT_VOID:
1044       /* This is for the second arg to c_f_pointer and c_f_procpointer
1045          of the iso_c_binding module, to accept any ptr type.  */
1046       basetype = ptr_type_node;
1047       if (spec->f90_type == BT_VOID)
1048         {
1049           if (spec->u.derived
1050               && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
1051             basetype = ptr_type_node;
1052           else
1053             basetype = pfunc_type_node;
1054         }
1055        break;
1056     default:
1057       gcc_unreachable ();
1058     }
1059   return basetype;
1060 }
1061 \f
1062 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
1063
1064 static tree
1065 gfc_conv_array_bound (gfc_expr * expr)
1066 {
1067   /* If expr is an integer constant, return that.  */
1068   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
1069     return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
1070
1071   /* Otherwise return NULL.  */
1072   return NULL_TREE;
1073 }
1074 \f
1075 tree
1076 gfc_get_element_type (tree type)
1077 {
1078   tree element;
1079
1080   if (GFC_ARRAY_TYPE_P (type))
1081     {
1082       if (TREE_CODE (type) == POINTER_TYPE)
1083         type = TREE_TYPE (type);
1084       gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
1085       element = TREE_TYPE (type);
1086     }
1087   else
1088     {
1089       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
1090       element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
1091
1092       gcc_assert (TREE_CODE (element) == POINTER_TYPE);
1093       element = TREE_TYPE (element);
1094
1095       gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
1096       element = TREE_TYPE (element);
1097     }
1098
1099   return element;
1100 }
1101 \f
1102 /* Build an array.  This function is called from gfc_sym_type().
1103    Actually returns array descriptor type.
1104
1105    Format of array descriptors is as follows:
1106
1107     struct gfc_array_descriptor
1108     {
1109       array *data
1110       index offset;
1111       index dtype;
1112       struct descriptor_dimension dimension[N_DIM];
1113     }
1114
1115     struct descriptor_dimension
1116     {
1117       index stride;
1118       index lbound;
1119       index ubound;
1120     }
1121
1122    Translation code should use gfc_conv_descriptor_* rather than
1123    accessing the descriptor directly.  Any changes to the array
1124    descriptor type will require changes in gfc_conv_descriptor_* and
1125    gfc_build_array_initializer.
1126
1127    This is represented internally as a RECORD_TYPE. The index nodes
1128    are gfc_array_index_type and the data node is a pointer to the
1129    data.  See below for the handling of character types.
1130
1131    The dtype member is formatted as follows:
1132     rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
1133     type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
1134     size = dtype >> GFC_DTYPE_SIZE_SHIFT
1135
1136    I originally used nested ARRAY_TYPE nodes to represent arrays, but
1137    this generated poor code for assumed/deferred size arrays.  These
1138    require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
1139    of the GENERIC grammar.  Also, there is no way to explicitly set
1140    the array stride, so all data must be packed(1).  I've tried to
1141    mark all the functions which would require modification with a GCC
1142    ARRAYS comment.
1143
1144    The data component points to the first element in the array.  The
1145    offset field is the position of the origin of the array (i.e. element
1146    (0, 0 ...)).  This may be outside the bounds of the array.
1147
1148    An element is accessed by
1149     data[offset + index0*stride0 + index1*stride1 + index2*stride2]
1150    This gives good performance as the computation does not involve the
1151    bounds of the array.  For packed arrays, this is optimized further
1152    by substituting the known strides.
1153
1154    This system has one problem: all array bounds must be within 2^31
1155    elements of the origin (2^63 on 64-bit machines).  For example
1156     integer, dimension (80000:90000, 80000:90000, 2) :: array
1157    may not work properly on 32-bit machines because 80000*80000 >
1158    2^31, so the calculation for stride2 would overflow.  This may
1159    still work, but I haven't checked, and it relies on the overflow
1160    doing the right thing.
1161
1162    The way to fix this problem is to access elements as follows:
1163     data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
1164    Obviously this is much slower.  I will make this a compile time
1165    option, something like -fsmall-array-offsets.  Mixing code compiled
1166    with and without this switch will work.
1167
1168    (1) This can be worked around by modifying the upper bound of the
1169    previous dimension.  This requires extra fields in the descriptor
1170    (both real_ubound and fake_ubound).  */
1171
1172
1173 /* Returns true if the array sym does not require a descriptor.  */
1174
1175 int
1176 gfc_is_nodesc_array (gfc_symbol * sym)
1177 {
1178   gcc_assert (sym->attr.dimension);
1179
1180   /* We only want local arrays.  */
1181   if (sym->attr.pointer || sym->attr.allocatable)
1182     return 0;
1183
1184   if (sym->attr.dummy)
1185     {
1186       if (sym->as->type != AS_ASSUMED_SHAPE)
1187         return 1;
1188       else
1189         return 0;
1190     }
1191
1192   if (sym->attr.result || sym->attr.function)
1193     return 0;
1194
1195   gcc_assert (sym->as->type == AS_EXPLICIT);
1196
1197   return 1;
1198 }
1199
1200
1201 /* Create an array descriptor type.  */
1202
1203 static tree
1204 gfc_build_array_type (tree type, gfc_array_spec * as,
1205                       enum gfc_array_kind akind)
1206 {
1207   tree lbound[GFC_MAX_DIMENSIONS];
1208   tree ubound[GFC_MAX_DIMENSIONS];
1209   int n;
1210
1211   for (n = 0; n < as->rank; n++)
1212     {
1213       /* Create expressions for the known bounds of the array.  */
1214       if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
1215         lbound[n] = gfc_index_one_node;
1216       else
1217         lbound[n] = gfc_conv_array_bound (as->lower[n]);
1218       ubound[n] = gfc_conv_array_bound (as->upper[n]);
1219     }
1220
1221   if (as->type == AS_ASSUMED_SHAPE)
1222     akind = GFC_ARRAY_ASSUMED_SHAPE;
1223   return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
1224 }
1225 \f
1226 /* Returns the struct descriptor_dimension type.  */
1227
1228 static tree
1229 gfc_get_desc_dim_type (void)
1230 {
1231   tree type;
1232   tree decl;
1233   tree fieldlist;
1234
1235   if (gfc_desc_dim_type)
1236     return gfc_desc_dim_type;
1237
1238   /* Build the type node.  */
1239   type = make_node (RECORD_TYPE);
1240
1241   TYPE_NAME (type) = get_identifier ("descriptor_dimension");
1242   TYPE_PACKED (type) = 1;
1243
1244   /* Consists of the stride, lbound and ubound members.  */
1245   decl = build_decl (input_location,
1246                      FIELD_DECL,
1247                      get_identifier ("stride"), gfc_array_index_type);
1248   DECL_CONTEXT (decl) = type;
1249   TREE_NO_WARNING (decl) = 1;
1250   fieldlist = decl;
1251
1252   decl = build_decl (input_location,
1253                      FIELD_DECL,
1254                      get_identifier ("lbound"), gfc_array_index_type);
1255   DECL_CONTEXT (decl) = type;
1256   TREE_NO_WARNING (decl) = 1;
1257   fieldlist = chainon (fieldlist, decl);
1258
1259   decl = build_decl (input_location,
1260                      FIELD_DECL,
1261                      get_identifier ("ubound"), gfc_array_index_type);
1262   DECL_CONTEXT (decl) = type;
1263   TREE_NO_WARNING (decl) = 1;
1264   fieldlist = chainon (fieldlist, decl);
1265
1266   /* Finish off the type.  */
1267   TYPE_FIELDS (type) = fieldlist;
1268
1269   gfc_finish_type (type);
1270   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
1271
1272   gfc_desc_dim_type = type;
1273   return type;
1274 }
1275
1276
1277 /* Return the DTYPE for an array.  This describes the type and type parameters
1278    of the array.  */
1279 /* TODO: Only call this when the value is actually used, and make all the
1280    unknown cases abort.  */
1281
1282 tree
1283 gfc_get_dtype (tree type)
1284 {
1285   tree size;
1286   int n;
1287   HOST_WIDE_INT i;
1288   tree tmp;
1289   tree dtype;
1290   tree etype;
1291   int rank;
1292
1293   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
1294
1295   if (GFC_TYPE_ARRAY_DTYPE (type))
1296     return GFC_TYPE_ARRAY_DTYPE (type);
1297
1298   rank = GFC_TYPE_ARRAY_RANK (type);
1299   etype = gfc_get_element_type (type);
1300
1301   switch (TREE_CODE (etype))
1302     {
1303     case INTEGER_TYPE:
1304       n = GFC_DTYPE_INTEGER;
1305       break;
1306
1307     case BOOLEAN_TYPE:
1308       n = GFC_DTYPE_LOGICAL;
1309       break;
1310
1311     case REAL_TYPE:
1312       n = GFC_DTYPE_REAL;
1313       break;
1314
1315     case COMPLEX_TYPE:
1316       n = GFC_DTYPE_COMPLEX;
1317       break;
1318
1319     /* We will never have arrays of arrays.  */
1320     case RECORD_TYPE:
1321       n = GFC_DTYPE_DERIVED;
1322       break;
1323
1324     case ARRAY_TYPE:
1325       n = GFC_DTYPE_CHARACTER;
1326       break;
1327
1328     default:
1329       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
1330       /* We can strange array types for temporary arrays.  */
1331       return gfc_index_zero_node;
1332     }
1333
1334   gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
1335   size = TYPE_SIZE_UNIT (etype);
1336
1337   i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
1338   if (size && INTEGER_CST_P (size))
1339     {
1340       if (tree_int_cst_lt (gfc_max_array_element_size, size))
1341         internal_error ("Array element size too big");
1342
1343       i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
1344     }
1345   dtype = build_int_cst (gfc_array_index_type, i);
1346
1347   if (size && !INTEGER_CST_P (size))
1348     {
1349       tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
1350       tmp  = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
1351                           fold_convert (gfc_array_index_type, size), tmp);
1352       dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
1353     }
1354   /* If we don't know the size we leave it as zero.  This should never happen
1355      for anything that is actually used.  */
1356   /* TODO: Check this is actually true, particularly when repacking
1357      assumed size parameters.  */
1358
1359   GFC_TYPE_ARRAY_DTYPE (type) = dtype;
1360   return dtype;
1361 }
1362
1363
1364 /* Build an array type for use without a descriptor, packed according
1365    to the value of PACKED.  */
1366
1367 tree
1368 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
1369 {
1370   tree range;
1371   tree type;
1372   tree tmp;
1373   int n;
1374   int known_stride;
1375   int known_offset;
1376   mpz_t offset;
1377   mpz_t stride;
1378   mpz_t delta;
1379   gfc_expr *expr;
1380
1381   mpz_init_set_ui (offset, 0);
1382   mpz_init_set_ui (stride, 1);
1383   mpz_init (delta);
1384
1385   /* We don't use build_array_type because this does not include include
1386      lang-specific information (i.e. the bounds of the array) when checking
1387      for duplicates.  */
1388   type = make_node (ARRAY_TYPE);
1389
1390   GFC_ARRAY_TYPE_P (type) = 1;
1391   TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
1392     ggc_alloc_cleared (sizeof (struct lang_type));
1393
1394   known_stride = (packed != PACKED_NO);
1395   known_offset = 1;
1396   for (n = 0; n < as->rank; n++)
1397     {
1398       /* Fill in the stride and bound components of the type.  */
1399       if (known_stride)
1400         tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1401       else
1402         tmp = NULL_TREE;
1403       GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
1404
1405       expr = as->lower[n];
1406       if (expr->expr_type == EXPR_CONSTANT)
1407         {
1408           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1409                                       gfc_index_integer_kind);
1410         }
1411       else
1412         {
1413           known_stride = 0;
1414           tmp = NULL_TREE;
1415         }
1416       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
1417
1418       if (known_stride)
1419         {
1420           /* Calculate the offset.  */
1421           mpz_mul (delta, stride, as->lower[n]->value.integer);
1422           mpz_sub (offset, offset, delta);
1423         }
1424       else
1425         known_offset = 0;
1426
1427       expr = as->upper[n];
1428       if (expr && expr->expr_type == EXPR_CONSTANT)
1429         {
1430           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
1431                                   gfc_index_integer_kind);
1432         }
1433       else
1434         {
1435           tmp = NULL_TREE;
1436           known_stride = 0;
1437         }
1438       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1439
1440       if (known_stride)
1441         {
1442           /* Calculate the stride.  */
1443           mpz_sub (delta, as->upper[n]->value.integer,
1444                    as->lower[n]->value.integer);
1445           mpz_add_ui (delta, delta, 1);
1446           mpz_mul (stride, stride, delta);
1447         }
1448
1449       /* Only the first stride is known for partial packed arrays.  */
1450       if (packed == PACKED_NO || packed == PACKED_PARTIAL)
1451         known_stride = 0;
1452     }
1453
1454   if (known_offset)
1455     {
1456       GFC_TYPE_ARRAY_OFFSET (type) =
1457         gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1458     }
1459   else
1460     GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1461
1462   if (known_stride)
1463     {
1464       GFC_TYPE_ARRAY_SIZE (type) =
1465         gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1466     }
1467   else
1468     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1469
1470   GFC_TYPE_ARRAY_RANK (type) = as->rank;
1471   GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
1472   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1473                             NULL_TREE);
1474   /* TODO: use main type if it is unbounded.  */
1475   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1476     build_pointer_type (build_array_type (etype, range));
1477
1478   if (known_stride)
1479     {
1480       mpz_sub_ui (stride, stride, 1);
1481       range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1482     }
1483   else
1484     range = NULL_TREE;
1485
1486   range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1487   TYPE_DOMAIN (type) = range;
1488
1489   build_pointer_type (etype);
1490   TREE_TYPE (type) = etype;
1491
1492   layout_type (type);
1493
1494   mpz_clear (offset);
1495   mpz_clear (stride);
1496   mpz_clear (delta);
1497
1498   /* Represent packed arrays as multi-dimensional if they have rank >
1499      1 and with proper bounds, instead of flat arrays.  This makes for
1500      better debug info.  */
1501   if (known_offset)
1502     {
1503       tree gtype = etype, rtype, type_decl;
1504
1505       for (n = as->rank - 1; n >= 0; n--)
1506         {
1507           rtype = build_range_type (gfc_array_index_type,
1508                                     GFC_TYPE_ARRAY_LBOUND (type, n),
1509                                     GFC_TYPE_ARRAY_UBOUND (type, n));
1510           gtype = build_array_type (gtype, rtype);
1511         }
1512       TYPE_NAME (type) = type_decl = build_decl (input_location,
1513                                                  TYPE_DECL, NULL, gtype);
1514       DECL_ORIGINAL_TYPE (type_decl) = gtype;
1515     }
1516
1517   if (packed != PACKED_STATIC || !known_stride)
1518     {
1519       /* For dummy arrays and automatic (heap allocated) arrays we
1520          want a pointer to the array.  */
1521       type = build_pointer_type (type);
1522       GFC_ARRAY_TYPE_P (type) = 1;
1523       TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1524     }
1525   return type;
1526 }
1527
1528 /* Return or create the base type for an array descriptor.  */
1529
1530 static tree
1531 gfc_get_array_descriptor_base (int dimen)
1532 {
1533   tree fat_type, fieldlist, decl, arraytype;
1534   char name[16 + GFC_RANK_DIGITS + 1];
1535
1536   gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
1537   if (gfc_array_descriptor_base[dimen - 1])
1538     return gfc_array_descriptor_base[dimen - 1];
1539
1540   /* Build the type node.  */
1541   fat_type = make_node (RECORD_TYPE);
1542
1543   sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
1544   TYPE_NAME (fat_type) = get_identifier (name);
1545
1546   /* Add the data member as the first element of the descriptor.  */
1547   decl = build_decl (input_location,
1548                      FIELD_DECL, get_identifier ("data"), ptr_type_node);
1549
1550   DECL_CONTEXT (decl) = fat_type;
1551   fieldlist = decl;
1552
1553   /* Add the base component.  */
1554   decl = build_decl (input_location,
1555                      FIELD_DECL, get_identifier ("offset"),
1556                      gfc_array_index_type);
1557   DECL_CONTEXT (decl) = fat_type;
1558   TREE_NO_WARNING (decl) = 1;
1559   fieldlist = chainon (fieldlist, decl);
1560
1561   /* Add the dtype component.  */
1562   decl = build_decl (input_location,
1563                      FIELD_DECL, get_identifier ("dtype"),
1564                      gfc_array_index_type);
1565   DECL_CONTEXT (decl) = fat_type;
1566   TREE_NO_WARNING (decl) = 1;
1567   fieldlist = chainon (fieldlist, decl);
1568
1569   /* Build the array type for the stride and bound components.  */
1570   arraytype =
1571     build_array_type (gfc_get_desc_dim_type (),
1572                       build_range_type (gfc_array_index_type,
1573                                         gfc_index_zero_node,
1574                                         gfc_rank_cst[dimen - 1]));
1575
1576   decl = build_decl (input_location,
1577                      FIELD_DECL, get_identifier ("dim"), arraytype);
1578   DECL_CONTEXT (decl) = fat_type;
1579   TREE_NO_WARNING (decl) = 1;
1580   fieldlist = chainon (fieldlist, decl);
1581
1582   /* Finish off the type.  */
1583   TYPE_FIELDS (fat_type) = fieldlist;
1584
1585   gfc_finish_type (fat_type);
1586   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
1587
1588   gfc_array_descriptor_base[dimen - 1] = fat_type;
1589   return fat_type;
1590 }
1591
1592 /* Build an array (descriptor) type with given bounds.  */
1593
1594 tree
1595 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1596                            tree * ubound, int packed,
1597                            enum gfc_array_kind akind)
1598 {
1599   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1600   tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
1601   const char *type_name;
1602   int n;
1603
1604   base_type = gfc_get_array_descriptor_base (dimen);
1605   fat_type = build_distinct_type_copy (base_type);
1606   TYPE_CANONICAL (fat_type) = base_type;
1607   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
1608
1609   tmp = TYPE_NAME (etype);
1610   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1611     tmp = DECL_NAME (tmp);
1612   if (tmp)
1613     type_name = IDENTIFIER_POINTER (tmp);
1614   else
1615     type_name = "unknown";
1616   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1617            GFC_MAX_SYMBOL_LEN, type_name);
1618   TYPE_NAME (fat_type) = get_identifier (name);
1619
1620   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1621   TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1622     ggc_alloc_cleared (sizeof (struct lang_type));
1623
1624   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1625   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
1626   GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
1627
1628   /* Build an array descriptor record type.  */
1629   if (packed != 0)
1630     stride = gfc_index_one_node;
1631   else
1632     stride = NULL_TREE;
1633   for (n = 0; n < dimen; n++)
1634     {
1635       GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1636
1637       if (lbound)
1638         lower = lbound[n];
1639       else
1640         lower = NULL_TREE;
1641
1642       if (lower != NULL_TREE)
1643         {
1644           if (INTEGER_CST_P (lower))
1645             GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1646           else
1647             lower = NULL_TREE;
1648         }
1649
1650       upper = ubound[n];
1651       if (upper != NULL_TREE)
1652         {
1653           if (INTEGER_CST_P (upper))
1654             GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1655           else
1656             upper = NULL_TREE;
1657         }
1658
1659       if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1660         {
1661           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
1662           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1663                              gfc_index_one_node);
1664           stride =
1665             fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
1666           /* Check the folding worked.  */
1667           gcc_assert (INTEGER_CST_P (stride));
1668         }
1669       else
1670         stride = NULL_TREE;
1671     }
1672   GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1673
1674   /* TODO: known offsets for descriptors.  */
1675   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1676
1677   /* We define data as an array with the correct size if possible.
1678      Much better than doing pointer arithmetic.  */
1679   if (stride)
1680     rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1681                               int_const_binop (MINUS_EXPR, stride,
1682                                                integer_one_node, 0));
1683   else
1684     rtype = gfc_array_range_type;
1685   arraytype = build_array_type (etype, rtype);
1686   arraytype = build_pointer_type (arraytype);
1687   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1688
1689   /* This will generate the base declarations we need to emit debug
1690      information for this type.  FIXME: there must be a better way to
1691      avoid divergence between compilations with and without debug
1692      information.  */
1693   {
1694     struct array_descr_info info;
1695     gfc_get_array_descr_info (fat_type, &info);
1696     gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
1697   }
1698
1699   return fat_type;
1700 }
1701 \f
1702 /* Build a pointer type. This function is called from gfc_sym_type().  */
1703
1704 static tree
1705 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1706 {
1707   /* Array pointer types aren't actually pointers.  */
1708   if (sym->attr.dimension)
1709     return type;
1710   else
1711     return build_pointer_type (type);
1712 }
1713 \f
1714 /* Return the type for a symbol.  Special handling is required for character
1715    types to get the correct level of indirection.
1716    For functions return the return type.
1717    For subroutines return void_type_node.
1718    Calling this multiple times for the same symbol should be avoided,
1719    especially for character and array types.  */
1720
1721 tree
1722 gfc_sym_type (gfc_symbol * sym)
1723 {
1724   tree type;
1725   int byref;
1726
1727   /* Procedure Pointers inside COMMON blocks.  */
1728   if (sym->attr.proc_pointer && sym->attr.in_common)
1729     {
1730       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
1731       sym->attr.proc_pointer = 0;
1732       type = build_pointer_type (gfc_get_function_type (sym));
1733       sym->attr.proc_pointer = 1;
1734       return type;
1735     }
1736
1737   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1738     return void_type_node;
1739
1740   /* In the case of a function the fake result variable may have a
1741      type different from the function type, so don't return early in
1742      that case.  */
1743   if (sym->backend_decl && !sym->attr.function)
1744     return TREE_TYPE (sym->backend_decl);
1745
1746   if (sym->ts.type == BT_CHARACTER
1747       && ((sym->attr.function && sym->attr.is_bind_c)
1748           || (sym->attr.result
1749               && sym->ns->proc_name
1750               && sym->ns->proc_name->attr.is_bind_c)))
1751     type = gfc_character1_type_node;
1752   else
1753     type = gfc_typenode_for_spec (&sym->ts);
1754
1755   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
1756     byref = 1;
1757   else
1758     byref = 0;
1759
1760   if (sym->attr.dimension)
1761     {
1762       if (gfc_is_nodesc_array (sym))
1763         {
1764           /* If this is a character argument of unknown length, just use the
1765              base type.  */
1766           if (sym->ts.type != BT_CHARACTER
1767               || !(sym->attr.dummy || sym->attr.function)
1768               || sym->ts.u.cl->backend_decl)
1769             {
1770               type = gfc_get_nodesc_array_type (type, sym->as,
1771                                                 byref ? PACKED_FULL
1772                                                       : PACKED_STATIC);
1773               byref = 0;
1774             }
1775         }
1776       else
1777         {
1778           enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
1779           if (sym->attr.pointer)
1780             akind = GFC_ARRAY_POINTER;
1781           else if (sym->attr.allocatable)
1782             akind = GFC_ARRAY_ALLOCATABLE;
1783           type = gfc_build_array_type (type, sym->as, akind);
1784         }
1785     }
1786   else
1787     {
1788       if (sym->attr.allocatable || sym->attr.pointer)
1789         type = gfc_build_pointer_type (sym, type);
1790       if (sym->attr.pointer)
1791         GFC_POINTER_TYPE_P (type) = 1;
1792     }
1793
1794   /* We currently pass all parameters by reference.
1795      See f95_get_function_decl.  For dummy function parameters return the
1796      function type.  */
1797   if (byref)
1798     {
1799       /* We must use pointer types for potentially absent variables.  The
1800          optimizers assume a reference type argument is never NULL.  */
1801       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1802         type = build_pointer_type (type);
1803       else
1804         type = build_reference_type (type);
1805     }
1806
1807   return (type);
1808 }
1809 \f
1810 /* Layout and output debug info for a record type.  */
1811
1812 void
1813 gfc_finish_type (tree type)
1814 {
1815   tree decl;
1816
1817   decl = build_decl (input_location,
1818                      TYPE_DECL, NULL_TREE, type);
1819   TYPE_STUB_DECL (type) = decl;
1820   layout_type (type);
1821   rest_of_type_compilation (type, 1);
1822   rest_of_decl_compilation (decl, 1, 0);
1823 }
1824 \f
1825 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1826    or RECORD_TYPE pointed to by STYPE.  The new field is chained
1827    to the fieldlist pointed to by FIELDLIST.
1828
1829    Returns a pointer to the new field.  */
1830
1831 tree
1832 gfc_add_field_to_struct (tree *fieldlist, tree context,
1833                          tree name, tree type)
1834 {
1835   tree decl;
1836
1837   decl = build_decl (input_location,
1838                      FIELD_DECL, name, type);
1839
1840   DECL_CONTEXT (decl) = context;
1841   DECL_INITIAL (decl) = 0;
1842   DECL_ALIGN (decl) = 0;
1843   DECL_USER_ALIGN (decl) = 0;
1844   TREE_CHAIN (decl) = NULL_TREE;
1845   *fieldlist = chainon (*fieldlist, decl);
1846
1847   return decl;
1848 }
1849
1850
1851 /* Copy the backend_decl and component backend_decls if
1852    the two derived type symbols are "equal", as described
1853    in 4.4.2 and resolved by gfc_compare_derived_types.  */
1854
1855 static int
1856 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
1857                        bool from_gsym)
1858 {
1859   gfc_component *to_cm;
1860   gfc_component *from_cm;
1861
1862   if (from->backend_decl == NULL
1863         || !gfc_compare_derived_types (from, to))
1864     return 0;
1865
1866   to->backend_decl = from->backend_decl;
1867
1868   to_cm = to->components;
1869   from_cm = from->components;
1870
1871   /* Copy the component declarations.  If a component is itself
1872      a derived type, we need a copy of its component declarations.
1873      This is done by recursing into gfc_get_derived_type and
1874      ensures that the component's component declarations have
1875      been built.  If it is a character, we need the character
1876      length, as well.  */
1877   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1878     {
1879       to_cm->backend_decl = from_cm->backend_decl;
1880       if ((!from_cm->attr.pointer || from_gsym)
1881               && from_cm->ts.type == BT_DERIVED)
1882         gfc_get_derived_type (to_cm->ts.u.derived);
1883
1884       else if (from_cm->ts.type == BT_CHARACTER)
1885         to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
1886     }
1887
1888   return 1;
1889 }
1890
1891
1892 /* Build a tree node for a procedure pointer component.  */
1893
1894 tree
1895 gfc_get_ppc_type (gfc_component* c)
1896 {
1897   tree t;
1898   if (c->attr.function && !c->attr.dimension)
1899     {
1900       if (c->ts.type == BT_DERIVED)
1901         t = c->ts.u.derived->backend_decl;
1902       else
1903         t = gfc_typenode_for_spec (&c->ts);
1904     }
1905   else
1906     t = void_type_node;
1907   /* TODO: Build argument list.  */
1908   return build_pointer_type (build_function_type (t, NULL_TREE));
1909 }
1910
1911
1912 /* Build a tree node for a derived type.  If there are equal
1913    derived types, with different local names, these are built
1914    at the same time.  If an equal derived type has been built
1915    in a parent namespace, this is used.  */
1916
1917 static tree
1918 gfc_get_derived_type (gfc_symbol * derived)
1919 {
1920   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1921   tree canonical = NULL_TREE;
1922   bool got_canonical = false;
1923   gfc_component *c;
1924   gfc_dt_list *dt;
1925   gfc_namespace *ns;
1926   gfc_gsymbol *gsym;
1927
1928   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1929
1930   /* See if it's one of the iso_c_binding derived types.  */
1931   if (derived->attr.is_iso_c == 1)
1932     {
1933       if (derived->backend_decl)
1934         return derived->backend_decl;
1935
1936       if (derived->intmod_sym_id == ISOCBINDING_PTR)
1937         derived->backend_decl = ptr_type_node;
1938       else
1939         derived->backend_decl = pfunc_type_node;
1940
1941       /* Create a backend_decl for the __c_ptr_c_address field.  */
1942       derived->components->backend_decl =
1943         gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1944                                  derived->backend_decl,
1945                                  get_identifier (derived->components->name),
1946                                  gfc_typenode_for_spec (
1947                                    &(derived->components->ts)));
1948
1949       derived->ts.kind = gfc_index_integer_kind;
1950       derived->ts.type = BT_INTEGER;
1951       /* Set the f90_type to BT_VOID as a way to recognize something of type
1952          BT_INTEGER that needs to fit a void * for the purpose of the
1953          iso_c_binding derived types.  */
1954       derived->ts.f90_type = BT_VOID;
1955
1956       return derived->backend_decl;
1957     }
1958
1959 /* If use associated, use the module type for this one.  */
1960   if (gfc_option.flag_whole_file
1961         && derived->backend_decl == NULL
1962         && derived->attr.use_assoc
1963         && derived->module)
1964     {
1965       gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
1966       if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1967         {
1968           gfc_symbol *s;
1969           s = NULL;
1970           gfc_find_symbol (derived->name, gsym->ns, 0, &s);
1971           if (s && s->backend_decl)
1972             {
1973               copy_dt_decls_ifequal (s, derived, true);
1974               goto copy_derived_types;
1975             }
1976         }
1977     }
1978
1979   /* If a whole file compilation, the derived types from an earlier
1980      namespace can be used as the the canonical type.  */
1981   if (gfc_option.flag_whole_file
1982         && derived->backend_decl == NULL
1983         && !derived->attr.use_assoc
1984         && gfc_global_ns_list)
1985     {
1986       for (ns = gfc_global_ns_list;
1987            ns->translated && !got_canonical;
1988            ns = ns->sibling)
1989         {
1990           dt = ns->derived_types;
1991           for (; dt && !canonical; dt = dt->next)
1992             {
1993               copy_dt_decls_ifequal (dt->derived, derived, true);
1994               if (derived->backend_decl)
1995                 got_canonical = true;
1996             }
1997         }
1998     }
1999
2000   /* Store up the canonical type to be added to this one.  */
2001   if (got_canonical)
2002     {
2003       if (TYPE_CANONICAL (derived->backend_decl))
2004         canonical = TYPE_CANONICAL (derived->backend_decl);
2005       else
2006         canonical = derived->backend_decl;
2007
2008       derived->backend_decl = NULL_TREE;
2009     }
2010
2011   /* derived->backend_decl != 0 means we saw it before, but its
2012      components' backend_decl may have not been built.  */
2013   if (derived->backend_decl)
2014     {
2015       /* Its components' backend_decl have been built.  */
2016       if (TYPE_FIELDS (derived->backend_decl))
2017         return derived->backend_decl;
2018       else
2019         typenode = derived->backend_decl;
2020     }
2021   else
2022     {
2023       /* We see this derived type first time, so build the type node.  */
2024       typenode = make_node (RECORD_TYPE);
2025       TYPE_NAME (typenode) = get_identifier (derived->name);
2026       TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2027       derived->backend_decl = typenode;
2028     }
2029
2030   /* Go through the derived type components, building them as
2031      necessary. The reason for doing this now is that it is
2032      possible to recurse back to this derived type through a
2033      pointer component (PR24092). If this happens, the fields
2034      will be built and so we can return the type.  */
2035   for (c = derived->components; c; c = c->next)
2036     {
2037       if (c->ts.type != BT_DERIVED)
2038         continue;
2039
2040       if ((!c->attr.pointer && !c->attr.proc_pointer)
2041           || c->ts.u.derived->backend_decl == NULL)
2042         c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
2043
2044       if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
2045         {
2046           /* Need to copy the modified ts from the derived type.  The
2047              typespec was modified because C_PTR/C_FUNPTR are translated
2048              into (void *) from derived types.  */
2049           c->ts.type = c->ts.u.derived->ts.type;
2050           c->ts.kind = c->ts.u.derived->ts.kind;
2051           c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2052           if (c->initializer)
2053             {
2054               c->initializer->ts.type = c->ts.type;
2055               c->initializer->ts.kind = c->ts.kind;
2056               c->initializer->ts.f90_type = c->ts.f90_type;
2057               c->initializer->expr_type = EXPR_NULL;
2058             }
2059         }
2060     }
2061
2062   if (TYPE_FIELDS (derived->backend_decl))
2063     return derived->backend_decl;
2064
2065   /* Build the type member list. Install the newly created RECORD_TYPE
2066      node as DECL_CONTEXT of each FIELD_DECL.  */
2067   fieldlist = NULL_TREE;
2068   for (c = derived->components; c; c = c->next)
2069     {
2070       if (c->attr.proc_pointer)
2071         field_type = gfc_get_ppc_type (c);
2072       else if (c->ts.type == BT_DERIVED)
2073         field_type = c->ts.u.derived->backend_decl;
2074       else
2075         {
2076           if (c->ts.type == BT_CHARACTER)
2077             {
2078               /* Evaluate the string length.  */
2079               gfc_conv_const_charlen (c->ts.u.cl);
2080               gcc_assert (c->ts.u.cl->backend_decl);
2081             }
2082
2083           field_type = gfc_typenode_for_spec (&c->ts);
2084         }
2085
2086       /* This returns an array descriptor type.  Initialization may be
2087          required.  */
2088       if (c->attr.dimension && !c->attr.proc_pointer)
2089         {
2090           if (c->attr.pointer || c->attr.allocatable)
2091             {
2092               enum gfc_array_kind akind;
2093               if (c->attr.pointer)
2094                 akind = GFC_ARRAY_POINTER;
2095               else
2096                 akind = GFC_ARRAY_ALLOCATABLE;
2097               /* Pointers to arrays aren't actually pointer types.  The
2098                  descriptors are separate, but the data is common.  */
2099               field_type = gfc_build_array_type (field_type, c->as, akind);
2100             }
2101           else
2102             field_type = gfc_get_nodesc_array_type (field_type, c->as,
2103                                                     PACKED_STATIC);
2104         }
2105       else if (c->attr.pointer)
2106         field_type = build_pointer_type (field_type);
2107
2108       field = gfc_add_field_to_struct (&fieldlist, typenode,
2109                                        get_identifier (c->name),
2110                                        field_type);
2111       if (c->loc.lb)
2112         gfc_set_decl_location (field, &c->loc);
2113       else if (derived->declared_at.lb)
2114         gfc_set_decl_location (field, &derived->declared_at);
2115
2116       DECL_PACKED (field) |= TYPE_PACKED (typenode);
2117
2118       gcc_assert (field);
2119       if (!c->backend_decl)
2120         c->backend_decl = field;
2121     }
2122
2123   /* Now we have the final fieldlist.  Record it, then lay out the
2124      derived type, including the fields.  */
2125   TYPE_FIELDS (typenode) = fieldlist;
2126   if (canonical)
2127     TYPE_CANONICAL (typenode) = canonical;
2128
2129   gfc_finish_type (typenode);
2130   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2131   if (derived->module && derived->ns->proc_name
2132       && derived->ns->proc_name->attr.flavor == FL_MODULE)
2133     {
2134       if (derived->ns->proc_name->backend_decl
2135           && TREE_CODE (derived->ns->proc_name->backend_decl)
2136              == NAMESPACE_DECL)
2137         {
2138           TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2139           DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2140             = derived->ns->proc_name->backend_decl;
2141         }
2142     }
2143
2144   derived->backend_decl = typenode;
2145
2146 copy_derived_types:
2147
2148   for (dt = gfc_derived_types; dt; dt = dt->next)
2149     copy_dt_decls_ifequal (derived, dt->derived, false);
2150
2151   return derived->backend_decl;
2152 }
2153
2154
2155 int
2156 gfc_return_by_reference (gfc_symbol * sym)
2157 {
2158   if (!sym->attr.function)
2159     return 0;
2160
2161   if (sym->attr.dimension)
2162     return 1;
2163
2164   if (sym->ts.type == BT_CHARACTER
2165       && !sym->attr.is_bind_c
2166       && (!sym->attr.result
2167           || !sym->ns->proc_name
2168           || !sym->ns->proc_name->attr.is_bind_c))
2169     return 1;
2170
2171   /* Possibly return complex numbers by reference for g77 compatibility.
2172      We don't do this for calls to intrinsics (as the library uses the
2173      -fno-f2c calling convention), nor for calls to functions which always
2174      require an explicit interface, as no compatibility problems can
2175      arise there.  */
2176   if (gfc_option.flag_f2c
2177       && sym->ts.type == BT_COMPLEX
2178       && !sym->attr.intrinsic && !sym->attr.always_explicit)
2179     return 1;
2180
2181   return 0;
2182 }
2183 \f
2184 static tree
2185 gfc_get_mixed_entry_union (gfc_namespace *ns)
2186 {
2187   tree type;
2188   tree decl;
2189   tree fieldlist;
2190   char name[GFC_MAX_SYMBOL_LEN + 1];
2191   gfc_entry_list *el, *el2;
2192
2193   gcc_assert (ns->proc_name->attr.mixed_entry_master);
2194   gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2195
2196   snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2197
2198   /* Build the type node.  */
2199   type = make_node (UNION_TYPE);
2200
2201   TYPE_NAME (type) = get_identifier (name);
2202   fieldlist = NULL;
2203
2204   for (el = ns->entries; el; el = el->next)
2205     {
2206       /* Search for duplicates.  */
2207       for (el2 = ns->entries; el2 != el; el2 = el2->next)
2208         if (el2->sym->result == el->sym->result)
2209           break;
2210
2211       if (el == el2)
2212         {
2213           decl = build_decl (input_location,
2214                              FIELD_DECL,
2215                              get_identifier (el->sym->result->name),
2216                              gfc_sym_type (el->sym->result));
2217           DECL_CONTEXT (decl) = type;
2218           fieldlist = chainon (fieldlist, decl);
2219         }
2220     }
2221
2222   /* Finish off the type.  */
2223   TYPE_FIELDS (type) = fieldlist;
2224
2225   gfc_finish_type (type);
2226   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2227   return type;
2228 }
2229 \f
2230 tree
2231 gfc_get_function_type (gfc_symbol * sym)
2232 {
2233   tree type;
2234   tree typelist;
2235   gfc_formal_arglist *f;
2236   gfc_symbol *arg;
2237   int nstr;
2238   int alternate_return;
2239
2240   /* Make sure this symbol is a function, a subroutine or the main
2241      program.  */
2242   gcc_assert (sym->attr.flavor == FL_PROCEDURE
2243               || sym->attr.flavor == FL_PROGRAM);
2244
2245   if (sym->backend_decl)
2246     return TREE_TYPE (sym->backend_decl);
2247
2248   nstr = 0;
2249   alternate_return = 0;
2250   typelist = NULL_TREE;
2251
2252   if (sym->attr.entry_master)
2253     {
2254       /* Additional parameter for selecting an entry point.  */
2255       typelist = gfc_chainon_list (typelist, gfc_array_index_type);
2256     }
2257
2258   if (sym->result)
2259     arg = sym->result;
2260   else
2261     arg = sym;
2262
2263   if (arg->ts.type == BT_CHARACTER)
2264     gfc_conv_const_charlen (arg->ts.u.cl);
2265
2266   /* Some functions we use an extra parameter for the return value.  */
2267   if (gfc_return_by_reference (sym))
2268     {
2269       type = gfc_sym_type (arg);
2270       if (arg->ts.type == BT_COMPLEX
2271           || arg->attr.dimension
2272           || arg->ts.type == BT_CHARACTER)
2273         type = build_reference_type (type);
2274
2275       typelist = gfc_chainon_list (typelist, type);
2276       if (arg->ts.type == BT_CHARACTER)
2277         typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2278     }
2279
2280   /* Build the argument types for the function.  */
2281   for (f = sym->formal; f; f = f->next)
2282     {
2283       arg = f->sym;
2284       if (arg)
2285         {
2286           /* Evaluate constant character lengths here so that they can be
2287              included in the type.  */
2288           if (arg->ts.type == BT_CHARACTER)
2289             gfc_conv_const_charlen (arg->ts.u.cl);
2290
2291           if (arg->attr.flavor == FL_PROCEDURE)
2292             {
2293               type = gfc_get_function_type (arg);
2294               type = build_pointer_type (type);
2295             }
2296           else
2297             type = gfc_sym_type (arg);
2298
2299           /* Parameter Passing Convention
2300
2301              We currently pass all parameters by reference.
2302              Parameters with INTENT(IN) could be passed by value.
2303              The problem arises if a function is called via an implicit
2304              prototype. In this situation the INTENT is not known.
2305              For this reason all parameters to global functions must be
2306              passed by reference.  Passing by value would potentially
2307              generate bad code.  Worse there would be no way of telling that
2308              this code was bad, except that it would give incorrect results.
2309
2310              Contained procedures could pass by value as these are never
2311              used without an explicit interface, and cannot be passed as
2312              actual parameters for a dummy procedure.  */
2313           if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2314             nstr++;
2315           typelist = gfc_chainon_list (typelist, type);
2316         }
2317       else
2318         {
2319           if (sym->attr.subroutine)
2320             alternate_return = 1;
2321         }
2322     }
2323
2324   /* Add hidden string length parameters.  */
2325   while (nstr--)
2326     typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2327
2328   if (typelist)
2329     typelist = gfc_chainon_list (typelist, void_type_node);
2330
2331   if (alternate_return)
2332     type = integer_type_node;
2333   else if (!sym->attr.function || gfc_return_by_reference (sym))
2334     type = void_type_node;
2335   else if (sym->attr.mixed_entry_master)
2336     type = gfc_get_mixed_entry_union (sym->ns);
2337   else if (gfc_option.flag_f2c
2338            && sym->ts.type == BT_REAL
2339            && sym->ts.kind == gfc_default_real_kind
2340            && !sym->attr.always_explicit)
2341     {
2342       /* Special case: f2c calling conventions require that (scalar)
2343          default REAL functions return the C type double instead.  f2c
2344          compatibility is only an issue with functions that don't
2345          require an explicit interface, as only these could be
2346          implemented in Fortran 77.  */
2347       sym->ts.kind = gfc_default_double_kind;
2348       type = gfc_typenode_for_spec (&sym->ts);
2349       sym->ts.kind = gfc_default_real_kind;
2350     }
2351   else if (sym->result && sym->result->attr.proc_pointer)
2352     /* Procedure pointer return values.  */
2353     {
2354       if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
2355         {
2356           /* Unset proc_pointer as gfc_get_function_type
2357              is called recursively.  */
2358           sym->result->attr.proc_pointer = 0;
2359           type = build_pointer_type (gfc_get_function_type (sym->result));
2360           sym->result->attr.proc_pointer = 1;
2361         }
2362       else
2363        type = gfc_sym_type (sym->result);
2364     }
2365   else
2366     type = gfc_sym_type (sym);
2367
2368   type = build_function_type (type, typelist);
2369
2370   return type;
2371 }
2372 \f
2373 /* Language hooks for middle-end access to type nodes.  */
2374
2375 /* Return an integer type with BITS bits of precision,
2376    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
2377
2378 tree
2379 gfc_type_for_size (unsigned bits, int unsignedp)
2380 {
2381   if (!unsignedp)
2382     {
2383       int i;
2384       for (i = 0; i <= MAX_INT_KINDS; ++i)
2385         {
2386           tree type = gfc_integer_types[i];
2387           if (type && bits == TYPE_PRECISION (type))
2388             return type;
2389         }
2390
2391       /* Handle TImode as a special case because it is used by some backends
2392          (e.g. ARM) even though it is not available for normal use.  */
2393 #if HOST_BITS_PER_WIDE_INT >= 64
2394       if (bits == TYPE_PRECISION (intTI_type_node))
2395         return intTI_type_node;
2396 #endif
2397     }
2398   else
2399     {
2400       if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2401         return unsigned_intQI_type_node;
2402       if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2403         return unsigned_intHI_type_node;
2404       if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2405         return unsigned_intSI_type_node;
2406       if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2407         return unsigned_intDI_type_node;
2408       if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2409         return unsigned_intTI_type_node;
2410     }
2411
2412   return NULL_TREE;
2413 }
2414
2415 /* Return a data type that has machine mode MODE.  If the mode is an
2416    integer, then UNSIGNEDP selects between signed and unsigned types.  */
2417
2418 tree
2419 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2420 {
2421   int i;
2422   tree *base;
2423
2424   if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2425     base = gfc_real_types;
2426   else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2427     base = gfc_complex_types;
2428   else if (SCALAR_INT_MODE_P (mode))
2429     return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2430   else if (VECTOR_MODE_P (mode))
2431     {
2432       enum machine_mode inner_mode = GET_MODE_INNER (mode);
2433       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2434       if (inner_type != NULL_TREE)
2435         return build_vector_type_for_mode (inner_type, mode);
2436       return NULL_TREE;
2437     }
2438   else
2439     return NULL_TREE;
2440
2441   for (i = 0; i <= MAX_REAL_KINDS; ++i)
2442     {
2443       tree type = base[i];
2444       if (type && mode == TYPE_MODE (type))
2445         return type;
2446     }
2447
2448   return NULL_TREE;
2449 }
2450
2451 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2452    in that case.  */
2453
2454 bool
2455 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2456 {
2457   int rank, dim;
2458   bool indirect = false;
2459   tree etype, ptype, field, t, base_decl;
2460   tree data_off, offset_off, dim_off, dim_size, elem_size;
2461   tree lower_suboff, upper_suboff, stride_suboff;
2462
2463   if (! GFC_DESCRIPTOR_TYPE_P (type))
2464     {
2465       if (! POINTER_TYPE_P (type))
2466         return false;
2467       type = TREE_TYPE (type);
2468       if (! GFC_DESCRIPTOR_TYPE_P (type))
2469         return false;
2470       indirect = true;
2471     }
2472
2473   rank = GFC_TYPE_ARRAY_RANK (type);
2474   if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2475     return false;
2476
2477   etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2478   gcc_assert (POINTER_TYPE_P (etype));
2479   etype = TREE_TYPE (etype);
2480   gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
2481   etype = TREE_TYPE (etype);
2482   /* Can't handle variable sized elements yet.  */
2483   if (int_size_in_bytes (etype) <= 0)
2484     return false;
2485   /* Nor non-constant lower bounds in assumed shape arrays.  */
2486   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2487     {
2488       for (dim = 0; dim < rank; dim++)
2489         if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2490             || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2491           return false;
2492     }
2493
2494   memset (info, '\0', sizeof (*info));
2495   info->ndimensions = rank;
2496   info->element_type = etype;
2497   ptype = build_pointer_type (gfc_array_index_type);
2498   base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
2499   if (!base_decl)
2500     {
2501       base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
2502                               indirect ? build_pointer_type (ptype) : ptype);
2503       GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
2504     }
2505   info->base_decl = base_decl;
2506   if (indirect)
2507     base_decl = build1 (INDIRECT_REF, ptype, base_decl);
2508
2509   if (GFC_TYPE_ARRAY_SPAN (type))
2510     elem_size = GFC_TYPE_ARRAY_SPAN (type);
2511   else
2512     elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2513   field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2514   data_off = byte_position (field);
2515   field = TREE_CHAIN (field);
2516   offset_off = byte_position (field);
2517   field = TREE_CHAIN (field);
2518   field = TREE_CHAIN (field);
2519   dim_off = byte_position (field);
2520   dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2521   field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2522   stride_suboff = byte_position (field);
2523   field = TREE_CHAIN (field);
2524   lower_suboff = byte_position (field);
2525   field = TREE_CHAIN (field);
2526   upper_suboff = byte_position (field);
2527
2528   t = base_decl;
2529   if (!integer_zerop (data_off))
2530     t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2531   t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2532   info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2533   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2534     info->allocated = build2 (NE_EXPR, boolean_type_node,
2535                               info->data_location, null_pointer_node);
2536   else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
2537     info->associated = build2 (NE_EXPR, boolean_type_node,
2538                                info->data_location, null_pointer_node);
2539
2540   for (dim = 0; dim < rank; dim++)
2541     {
2542       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2543                   size_binop (PLUS_EXPR, dim_off, lower_suboff));
2544       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2545       info->dimen[dim].lower_bound = t;
2546       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2547                   size_binop (PLUS_EXPR, dim_off, upper_suboff));
2548       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2549       info->dimen[dim].upper_bound = t;
2550       if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2551         {
2552           /* Assumed shape arrays have known lower bounds.  */
2553           info->dimen[dim].upper_bound
2554             = build2 (MINUS_EXPR, gfc_array_index_type,
2555                       info->dimen[dim].upper_bound,
2556                       info->dimen[dim].lower_bound);
2557           info->dimen[dim].lower_bound
2558             = fold_convert (gfc_array_index_type,
2559                             GFC_TYPE_ARRAY_LBOUND (type, dim));
2560           info->dimen[dim].upper_bound
2561             = build2 (PLUS_EXPR, gfc_array_index_type,
2562                       info->dimen[dim].lower_bound,
2563                       info->dimen[dim].upper_bound);
2564         }
2565       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2566                   size_binop (PLUS_EXPR, dim_off, stride_suboff));
2567       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2568       t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2569       info->dimen[dim].stride = t;
2570       dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2571     }
2572
2573   return true;
2574 }
2575
2576 #include "gt-fortran-trans-types.h"