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