gcc/fortran/trans-types.c

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