gcc/fortran/trans-types.c

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