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