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