gcc/fortran/trans-types.c

   1 /* Backend support for Fortran 95 basic types and derived types.
   2    Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  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 <stdio.h>
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include <assert.h>
  33 #include "gfortran.h"
  34 #include "trans.h"
  35 #include "trans-types.h"
  36 #include "trans-const.h"
  37 \f
  38
  39 #if (GFC_MAX_DIMENSIONS < 10)
  40 #define GFC_RANK_DIGITS 1
  41 #define GFC_RANK_PRINTF_FORMAT "%01d"
  42 #elif (GFC_MAX_DIMENSIONS < 100)
  43 #define GFC_RANK_DIGITS 2
  44 #define GFC_RANK_PRINTF_FORMAT "%02d"
  45 #else
  46 #error If you really need >99 dimensions, continue the sequence above...
  47 #endif
  48
  49 static tree gfc_get_derived_type (gfc_symbol * derived);
  50
  51 tree gfc_type_nodes[NUM_F95_TYPES];
  52
  53 tree gfc_array_index_type;
  54 tree pvoid_type_node;
  55 tree ppvoid_type_node;
  56 tree pchar_type_node;
  57
  58 static GTY(()) tree gfc_desc_dim_type = NULL;
  59
  60 static GTY(()) tree gfc_max_array_element_size;
  61
  62 /* Create the backend type nodes. We map them to their
  63    equivalent C type, at least for now.  We also give
  64    names to the types here, and we push them in the
  65    global binding level context.*/
  66
  67 void
  68 gfc_init_types (void)
  69 {
  70   unsigned n;
  71   unsigned HOST_WIDE_INT hi;
  72   unsigned HOST_WIDE_INT lo;
  73
  74   /* Name the types.  */
  75 #define PUSH_TYPE(name, node) \
  76   pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
  77
  78   gfc_int1_type_node = signed_char_type_node;
  79   PUSH_TYPE ("int1", gfc_int1_type_node);
  80   gfc_int2_type_node = short_integer_type_node;
  81   PUSH_TYPE ("int2", gfc_int2_type_node);
  82   gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ );
  83   PUSH_TYPE ("int4", gfc_int4_type_node);
  84   gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ );
  85   PUSH_TYPE ("int8", gfc_int8_type_node);
  86 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
  87   gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ );
  88   PUSH_TYPE ("int16", gfc_int16_type_node);
  89 #endif
  90
  91   gfc_real4_type_node = float_type_node;
  92   PUSH_TYPE ("real4", gfc_real4_type_node);
  93   gfc_real8_type_node = double_type_node;
  94   PUSH_TYPE ("real8", gfc_real8_type_node);
  95 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
  96   /* Hmm, this will not work. Ref. g77 */
  97   gfc_real16_type_node = long_double_type_node;
  98   PUSH_TYPE ("real16", gfc_real16_type_node);
  99 #endif
 100
 101   gfc_complex4_type_node = complex_float_type_node;
 102   PUSH_TYPE ("complex4", gfc_complex4_type_node);
 103   gfc_complex8_type_node = complex_double_type_node;
 104   PUSH_TYPE ("complex8", gfc_complex8_type_node);
 105 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 106   /* Hmm, this will not work. Ref. g77 */
 107   gfc_complex16_type_node = complex_long_double_type_node;
 108   PUSH_TYPE ("complex16", gfc_complex16_type_node);
 109 #endif
 110
 111   gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
 112   TYPE_PRECISION (gfc_logical1_type_node) = 8;
 113   fixup_unsigned_type (gfc_logical1_type_node);
 114   PUSH_TYPE ("logical1", gfc_logical1_type_node);
 115   gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
 116   TYPE_PRECISION (gfc_logical2_type_node) = 16;
 117   fixup_unsigned_type (gfc_logical2_type_node);
 118   PUSH_TYPE ("logical2", gfc_logical2_type_node);
 119   gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
 120   TYPE_PRECISION (gfc_logical4_type_node) = 32;
 121   fixup_unsigned_type (gfc_logical4_type_node);
 122   PUSH_TYPE ("logical4", gfc_logical4_type_node);
 123   gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
 124   TYPE_PRECISION (gfc_logical8_type_node) = 64;
 125   fixup_unsigned_type (gfc_logical8_type_node);
 126   PUSH_TYPE ("logical8", gfc_logical8_type_node);
 127 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 128   gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
 129   TYPE_PRECISION (gfc_logical16_type_node) = 128;
 130   fixup_unsigned_type (gfc_logical16_type_node);
 131   PUSH_TYPE ("logical16", gfc_logical16_type_node);
 132 #endif
 133
 134   gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
 135   PUSH_TYPE ("char", gfc_character1_type_node);
 136
 137   PUSH_TYPE ("byte", unsigned_char_type_node);
 138   PUSH_TYPE ("void", void_type_node);
 139
 140   /* DBX debugging output gets upset if these aren't set.  */
 141   if (!TYPE_NAME (integer_type_node))
 142     PUSH_TYPE ("c_integer", integer_type_node);
 143   if (!TYPE_NAME (char_type_node))
 144     PUSH_TYPE ("c_char", char_type_node);
 145 #undef PUSH_TYPE
 146
 147   pvoid_type_node = build_pointer_type (void_type_node);
 148   ppvoid_type_node = build_pointer_type (pvoid_type_node);
 149   pchar_type_node = build_pointer_type (gfc_character1_type_node);
 150
 151   gfc_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8;
 152   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
 153
 154   /* The maximum array element size that can be handled is determined
 155      by the number of bits available to store this field in the array
 156      descriptor.  */
 157
 158   n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type))
 159       - GFC_DTYPE_SIZE_SHIFT;
 160
 161   if (n > sizeof (HOST_WIDE_INT) * 8)
 162     {
 163       lo = ~(unsigned HOST_WIDE_INT) 0;
 164       hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n);
 165     }
 166   else
 167     {
 168       hi = 0;
 169       lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n);
 170     }
 171   gfc_max_array_element_size = build_int_cst (long_unsigned_type_node, lo, hi);
 172
 173   size_type_node = gfc_array_index_type;
 174   boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ());
 175
 176   boolean_true_node = build_int_cst (boolean_type_node, 1, 0);
 177   boolean_false_node = build_int_cst (boolean_type_node, 0, 0);
 178 }
 179
 180 /* Get a type node for an integer kind.  */
 181
 182 tree
 183 gfc_get_int_type (int kind)
 184 {
 185   switch (kind)
 186     {
 187     case 1:
 188       return (gfc_int1_type_node);
 189     case 2:
 190       return (gfc_int2_type_node);
 191     case 4:
 192       return (gfc_int4_type_node);
 193     case 8:
 194       return (gfc_int8_type_node);
 195 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 196     case 16:
 197       return (95 _int16_type_node);
 198 #endif
 199     default:
 200       fatal_error ("integer kind=%d not available", kind);
 201     }
 202 }
 203
 204 /* Get a type node for a real kind.  */
 205
 206 tree
 207 gfc_get_real_type (int kind)
 208 {
 209   switch (kind)
 210     {
 211     case 4:
 212       return (gfc_real4_type_node);
 213     case 8:
 214       return (gfc_real8_type_node);
 215 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 216     case 16:
 217       return (gfc_real16_type_node);
 218 #endif
 219     default:
 220       fatal_error ("real kind=%d not available", kind);
 221     }
 222 }
 223
 224 /* Get a type node for a complex kind.  */
 225
 226 tree
 227 gfc_get_complex_type (int kind)
 228 {
 229
 230   switch (kind)
 231     {
 232     case 4:
 233       return (gfc_complex4_type_node);
 234     case 8:
 235       return (gfc_complex8_type_node);
 236 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 237     case 16:
 238       return (gfc_complex16_type_node);
 239 #endif
 240     default:
 241       fatal_error ("complex kind=%d not available", kind);
 242     }
 243 }
 244
 245 /* Get a type node for a logical kind.  */
 246
 247 tree
 248 gfc_get_logical_type (int kind)
 249 {
 250   switch (kind)
 251     {
 252     case 1:
 253       return (gfc_logical1_type_node);
 254     case 2:
 255       return (gfc_logical2_type_node);
 256     case 4:
 257       return (gfc_logical4_type_node);
 258     case 8:
 259       return (gfc_logical8_type_node);
 260 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 261     case 16:
 262       return (gfc_logical16_type_node);
 263 #endif
 264     default:
 265       fatal_error ("logical kind=%d not available", kind);
 266     }
 267 }
 268 \f
 269 /* Get a type node for a character kind.  */
 270
 271 tree
 272 gfc_get_character_type (int kind, gfc_charlen * cl)
 273 {
 274   tree base;
 275   tree type;
 276   tree len;
 277   tree bounds;
 278
 279   switch (kind)
 280     {
 281     case 1:
 282       base = gfc_character1_type_node;
 283       break;
 284
 285     default:
 286       fatal_error ("character kind=%d not available", kind);
 287     }
 288
 289   len = (cl == 0) ? NULL_TREE : cl->backend_decl;
 290
 291   bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
 292   type = build_array_type (base, bounds);
 293   TYPE_STRING_FLAG (type) = 1;
 294
 295   return type;
 296 }
 297 \f
 298 /* Covert a basic type.  This will be an array for character types.  */
 299
 300 tree
 301 gfc_typenode_for_spec (gfc_typespec * spec)
 302 {
 303   tree basetype;
 304
 305   switch (spec->type)
 306     {
 307     case BT_UNKNOWN:
 308       abort ();
 309       break;
 310
 311     case BT_INTEGER:
 312       basetype = gfc_get_int_type (spec->kind);
 313       break;
 314
 315     case BT_REAL:
 316       basetype = gfc_get_real_type (spec->kind);
 317       break;
 318
 319     case BT_COMPLEX:
 320       basetype = gfc_get_complex_type (spec->kind);
 321       break;
 322
 323     case BT_LOGICAL:
 324       basetype = gfc_get_logical_type (spec->kind);
 325       break;
 326
 327     case BT_CHARACTER:
 328       basetype = gfc_get_character_type (spec->kind, spec->cl);
 329       break;
 330
 331     case BT_DERIVED:
 332       basetype = gfc_get_derived_type (spec->derived);
 333       break;
 334
 335     default:
 336       abort ();
 337       break;
 338     }
 339   return basetype;
 340 }
 341 \f
 342 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
 343
 344 static tree
 345 gfc_conv_array_bound (gfc_expr * expr)
 346 {
 347   /* If expr is an integer constant, return that.  */
 348   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
 349     return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
 350
 351   /* Otherwise return NULL.  */
 352   return NULL_TREE;
 353 }
 354 \f
 355 tree
 356 gfc_get_element_type (tree type)
 357 {
 358   tree element;
 359
 360   if (GFC_ARRAY_TYPE_P (type))
 361     {
 362       if (TREE_CODE (type) == POINTER_TYPE)
 363         type = TREE_TYPE (type);
 364       assert (TREE_CODE (type) == ARRAY_TYPE);
 365       element = TREE_TYPE (type);
 366     }
 367   else
 368     {
 369       assert (GFC_DESCRIPTOR_TYPE_P (type));
 370       element = TREE_TYPE (TYPE_FIELDS (type));
 371
 372       assert (TREE_CODE (element) == POINTER_TYPE);
 373       element = TREE_TYPE (element);
 374
 375       assert (TREE_CODE (element) == ARRAY_TYPE);
 376       element = TREE_TYPE (element);
 377     }
 378
 379   return element;
 380 }
 381 \f
 382 /* Build an array. This function is called from gfc_sym_type().
 383    Actually returns array descriptor type.
 384
 385    Format of array descriptors is as follows:
 386
 387     struct gfc_array_descriptor
 388     {
 389       array *data
 390       index offset;
 391       index dtype;
 392       struct descriptor_dimension dimension[N_DIM];
 393     }
 394
 395     struct descriptor_dimension
 396     {
 397       index stride;
 398       index lbound;
 399       index ubound;
 400     }
 401
 402    Translation code should use gfc_conv_descriptor_* rather than accessing
 403    the descriptor directly. Any changes to the array descriptor type will
 404    require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
 405
 406    This is represented internally as a RECORD_TYPE. The index nodes are
 407    gfc_array_index_type and the data node is a pointer to the data. See below
 408    for the handling of character types.
 409
 410    The dtype member is formatted as follows:
 411     rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
 412     type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
 413     size = dtype >> GFC_DTYPE_SIZE_SHIFT
 414
 415    I originally used nested ARRAY_TYPE nodes to represent arrays, but this
 416    generated poor code for assumed/deferred size arrays.  These require
 417    use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
 418    grammar.  Also, there is no way to explicitly set the array stride, so
 419    all data must be packed(1).  I've tried to mark all the functions which
 420    would require modification with a GCC ARRAYS comment.
 421
 422    The data component points to the first element in the array.
 423    The offset field is the position of the origin of the array
 424    (ie element (0, 0 ...)).  This may be outsite the bounds of the array.
 425
 426    An element is accessed by
 427    data[offset + index0*stride0 + index1*stride1 + index2*stride2]
 428    This gives good performance as the computation does not involve the
 429    bounds of the array.  For packed arrays, this is optimized further by
 430    substituting the known strides.
 431
 432    This system has one problem: all array bounds must be withing 2^31 elements
 433    of the origin (2^63 on 64-bit machines).  For example
 434    integer, dimension (80000:90000, 80000:90000, 2) :: array
 435    may not work properly on 32-bit machines because 80000*80000 > 2^31, so
 436    the calculation for stride02 would overflow.  This may still work, but
 437    I haven't checked, and it relies on the overflow doing the right thing.
 438
 439    The way to fix this problem is to access alements as follows:
 440    data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
 441    Obviously this is much slower.  I will make this a compile time option,
 442    something like -fsmall-array-offsets.  Mixing code compiled with and without
 443    this switch will work.
 444
 445    (1) This can be worked around by modifying the upper bound of the previous
 446    dimension.  This requires extra fields in the descriptor (both real_ubound
 447    and fake_ubound).  In tree.def there is mention of TYPE_SEP, which
 448    may allow us to do this.  However I can't find mention of this anywhere
 449    else.  */
 450
 451
 452 /* Returns true if the array sym does not require a descriptor.  */
 453
 454 int
 455 gfc_is_nodesc_array (gfc_symbol * sym)
 456 {
 457   assert (sym->attr.dimension);
 458
 459   /* We only want local arrays.  */
 460   if (sym->attr.pointer || sym->attr.allocatable)
 461     return 0;
 462
 463   if (sym->attr.dummy)
 464     {
 465       if (sym->as->type != AS_ASSUMED_SHAPE)
 466         return 1;
 467       else
 468         return 0;
 469     }
 470
 471   if (sym->attr.result || sym->attr.function)
 472     return 0;
 473
 474   if (sym->attr.pointer || sym->attr.allocatable)
 475     return 0;
 476
 477   assert (sym->as->type == AS_EXPLICIT);
 478
 479   return 1;
 480 }
 481
 482 static tree
 483 gfc_build_array_type (tree type, gfc_array_spec * as)
 484 {
 485   tree lbound[GFC_MAX_DIMENSIONS];
 486   tree ubound[GFC_MAX_DIMENSIONS];
 487   int n;
 488
 489   for (n = 0; n < as->rank; n++)
 490     {
 491       /* Create expressions for the known bounds of the array.  */
 492       if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
 493         lbound[n] = gfc_index_one_node;
 494       else
 495         lbound[n] = gfc_conv_array_bound (as->lower[n]);
 496       ubound[n] = gfc_conv_array_bound (as->upper[n]);
 497     }
 498
 499   return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
 500 }
 501 \f
 502 /* Returns the struct descriptor_dimension type.  */
 503
 504 static tree
 505 gfc_get_desc_dim_type (void)
 506 {
 507   tree type;
 508   tree decl;
 509   tree fieldlist;
 510
 511   if (gfc_desc_dim_type)
 512     return gfc_desc_dim_type;
 513
 514   /* Build the type node.  */
 515   type = make_node (RECORD_TYPE);
 516
 517   TYPE_NAME (type) = get_identifier ("descriptor_dimension");
 518   TYPE_PACKED (type) = 1;
 519
 520   /* Consists of the stride, lbound and ubound members.  */
 521   decl = build_decl (FIELD_DECL,
 522                      get_identifier ("stride"), gfc_array_index_type);
 523   DECL_CONTEXT (decl) = type;
 524   fieldlist = decl;
 525
 526   decl = build_decl (FIELD_DECL,
 527                      get_identifier ("lbound"), gfc_array_index_type);
 528   DECL_CONTEXT (decl) = type;
 529   fieldlist = chainon (fieldlist, decl);
 530
 531   decl = build_decl (FIELD_DECL,
 532                      get_identifier ("ubound"), gfc_array_index_type);
 533   DECL_CONTEXT (decl) = type;
 534   fieldlist = chainon (fieldlist, decl);
 535
 536   /* Finish off the type.  */
 537   TYPE_FIELDS (type) = fieldlist;
 538
 539   gfc_finish_type (type);
 540
 541   gfc_desc_dim_type = type;
 542   return type;
 543 }
 544
 545 static tree
 546 gfc_get_dtype (tree type, int rank)
 547 {
 548   tree size;
 549   int n;
 550   HOST_WIDE_INT i;
 551   tree tmp;
 552   tree dtype;
 553
 554   if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
 555     return (GFC_TYPE_ARRAY_DTYPE (type));
 556
 557   /* TODO: Correctly identify LOGICAL types.  */
 558   switch (TREE_CODE (type))
 559     {
 560     case INTEGER_TYPE:
 561       n = GFC_DTYPE_INTEGER;
 562       break;
 563
 564     case BOOLEAN_TYPE:
 565       n = GFC_DTYPE_LOGICAL;
 566       break;
 567
 568     case REAL_TYPE:
 569       n = GFC_DTYPE_REAL;
 570       break;
 571
 572     case COMPLEX_TYPE:
 573       n = GFC_DTYPE_COMPLEX;
 574       break;
 575
 576     /* Arrays have already been dealt with.  */
 577     case RECORD_TYPE:
 578       n = GFC_DTYPE_DERIVED;
 579       break;
 580
 581     case ARRAY_TYPE:
 582       n = GFC_DTYPE_CHARACTER;
 583       break;
 584
 585     default:
 586       abort ();
 587     }
 588
 589   assert (rank <= GFC_DTYPE_RANK_MASK);
 590   size = TYPE_SIZE_UNIT (type);
 591
 592   i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
 593   if (size && INTEGER_CST_P (size))
 594     {
 595       if (tree_int_cst_lt (gfc_max_array_element_size, size))
 596         internal_error ("Array element size too big");
 597
 598       i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
 599     }
 600   dtype = build_int_cst (gfc_array_index_type, i, 0);
 601
 602   if (size && !INTEGER_CST_P (size))
 603     {
 604       tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT, 0);
 605       tmp  = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
 606       dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
 607     }
 608   /* If we don't know the size we leave it as zero.  This should never happen
 609      for anything that is actually used.  */
 610   /* TODO: Check this is actually true, particularly when repacking
 611      assumed size parameters.  */
 612
 613   return dtype;
 614 }
 615
 616
 617 /* Build an array type for use without a descriptor.  Valid values of packed
 618    are 0=no, 1=partial, 2=full, 3=static.  */
 619
 620 tree
 621 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
 622 {
 623   tree range;
 624   tree type;
 625   tree tmp;
 626   int n;
 627   int known_stride;
 628   int known_offset;
 629   mpz_t offset;
 630   mpz_t stride;
 631   mpz_t delta;
 632   gfc_expr *expr;
 633
 634   mpz_init_set_ui (offset, 0);
 635   mpz_init_set_ui (stride, 1);
 636   mpz_init (delta);
 637
 638   /* We don't use build_array_type because this does not include include
 639      lang-specific information (ie. the bounds of the array) when checking
 640      for duplicates.  */
 641   type = make_node (ARRAY_TYPE);
 642
 643   GFC_ARRAY_TYPE_P (type) = 1;
 644   TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
 645     ggc_alloc_cleared (sizeof (struct lang_type));
 646
 647   known_stride = (packed != 0);
 648   known_offset = 1;
 649   for (n = 0; n < as->rank; n++)
 650     {
 651       /* Fill in the stride and bound components of the type.  */
 652       if (known_stride)
 653         tmp =  gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
 654       else
 655         tmp = NULL_TREE;
 656       GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
 657
 658       expr = as->lower[n];
 659       if (expr->expr_type == EXPR_CONSTANT)
 660         {
 661           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
 662                                   gfc_index_integer_kind);
 663         }
 664       else
 665         {
 666           known_stride = 0;
 667           tmp = NULL_TREE;
 668         }
 669       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
 670
 671       if (known_stride)
 672         {
 673           /* Calculate the offset.  */
 674           mpz_mul (delta, stride, as->lower[n]->value.integer);
 675           mpz_sub (offset, offset, delta);
 676         }
 677       else
 678         known_offset = 0;
 679
 680       expr = as->upper[n];
 681       if (expr && expr->expr_type == EXPR_CONSTANT)
 682         {
 683           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
 684                                   gfc_index_integer_kind);
 685         }
 686       else
 687         {
 688           tmp = NULL_TREE;
 689           known_stride = 0;
 690         }
 691       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
 692
 693       if (known_stride)
 694         {
 695           /* Calculate the stride.  */
 696           mpz_sub (delta, as->upper[n]->value.integer,
 697                    as->lower[n]->value.integer);
 698           mpz_add_ui (delta, delta, 1);
 699           mpz_mul (stride, stride, delta);
 700         }
 701
 702       /* Only the first stride is known for partial packed arrays.  */
 703       if (packed < 2)
 704         known_stride = 0;
 705     }
 706
 707   if (known_offset)
 708     {
 709       GFC_TYPE_ARRAY_OFFSET (type) =
 710         gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
 711     }
 712   else
 713     GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
 714
 715   if (known_stride)
 716     {
 717       GFC_TYPE_ARRAY_SIZE (type) =
 718         gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
 719     }
 720   else
 721     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
 722
 723   GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
 724   GFC_TYPE_ARRAY_RANK (type) = as->rank;
 725   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 726                             NULL_TREE);
 727   /* TODO: use main type if it is unbounded.  */
 728   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
 729     build_pointer_type (build_array_type (etype, range));
 730
 731   if (known_stride)
 732     {
 733       mpz_sub_ui (stride, stride, 1);
 734       range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
 735     }
 736   else
 737     range = NULL_TREE;
 738
 739   range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
 740   TYPE_DOMAIN (type) = range;
 741
 742   build_pointer_type (etype);
 743   TREE_TYPE (type) = etype;
 744
 745   layout_type (type);
 746
 747   mpz_clear (offset);
 748   mpz_clear (stride);
 749   mpz_clear (delta);
 750
 751   if (packed < 3 || !known_stride)
 752     {
 753       /* For dummy arrays and automatic (heap allocated) arrays we
 754          want a pointer to the array.  */
 755       type = build_pointer_type (type);
 756       GFC_ARRAY_TYPE_P (type) = 1;
 757       TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
 758     }
 759   return type;
 760 }
 761
 762
 763 /* Build an array (descriptor) type with given bounds.  */
 764
 765 tree
 766 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
 767                            tree * ubound, int packed)
 768 {
 769   tree fat_type, fat_pointer_type;
 770   tree fieldlist;
 771   tree arraytype;
 772   tree decl;
 773   int n;
 774   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
 775   const char *typename;
 776   tree lower;
 777   tree upper;
 778   tree stride;
 779   tree tmp;
 780
 781   /* Build the type node.  */
 782   fat_type = make_node (RECORD_TYPE);
 783   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
 784   TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
 785     ggc_alloc_cleared (sizeof (struct lang_type));
 786   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
 787   GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
 788
 789   tmp = TYPE_NAME (etype);
 790   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
 791     tmp = DECL_NAME (tmp);
 792   if (tmp)
 793     typename = IDENTIFIER_POINTER (tmp);
 794   else
 795     typename = "unknown";
 796
 797   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
 798            GFC_MAX_SYMBOL_LEN, typename);
 799   TYPE_NAME (fat_type) = get_identifier (name);
 800   TYPE_PACKED (fat_type) = 0;
 801
 802   fat_pointer_type = build_pointer_type (fat_type);
 803
 804   /* Build an array descriptor record type.  */
 805   if (packed != 0)
 806     stride = gfc_index_one_node;
 807   else
 808     stride = NULL_TREE;
 809
 810   for (n = 0; n < dimen; n++)
 811     {
 812       GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
 813
 814       if (lbound)
 815         lower = lbound[n];
 816       else
 817         lower = NULL_TREE;
 818
 819       if (lower != NULL_TREE)
 820         {
 821           if (INTEGER_CST_P (lower))
 822             GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
 823           else
 824             lower = NULL_TREE;
 825         }
 826
 827       upper = ubound[n];
 828       if (upper != NULL_TREE)
 829         {
 830           if (INTEGER_CST_P (upper))
 831             GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
 832           else
 833             upper = NULL_TREE;
 834         }
 835
 836       if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
 837         {
 838           tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
 839           tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
 840                              gfc_index_one_node));
 841           stride =
 842             fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
 843           /* Check the folding worked.  */
 844           assert (INTEGER_CST_P (stride));
 845         }
 846       else
 847         stride = NULL_TREE;
 848     }
 849   GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
 850   /* TODO: known offsets for descriptors.  */
 851   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
 852
 853   /* We define data as an unknown size array. Much better than doing
 854      pointer arithmetic.  */
 855   arraytype =
 856     build_array_type (etype,
 857                       build_range_type (gfc_array_index_type,
 858                                         gfc_index_zero_node, NULL_TREE));
 859   arraytype = build_pointer_type (arraytype);
 860   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
 861
 862   /* The pointer to the array data.  */
 863   decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
 864
 865   DECL_CONTEXT (decl) = fat_type;
 866   /* Add the data member as the first element of the descriptor.  */
 867   fieldlist = decl;
 868
 869   /* Add the base component.  */
 870   decl = build_decl (FIELD_DECL, get_identifier ("offset"),
 871                      gfc_array_index_type);
 872   DECL_CONTEXT (decl) = fat_type;
 873   fieldlist = chainon (fieldlist, decl);
 874
 875   /* Add the dtype component.  */
 876   decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
 877                      gfc_array_index_type);
 878   DECL_CONTEXT (decl) = fat_type;
 879   fieldlist = chainon (fieldlist, decl);
 880
 881   /* Build the array type for the stride and bound components.  */
 882   arraytype =
 883     build_array_type (gfc_get_desc_dim_type (),
 884                       build_range_type (gfc_array_index_type,
 885                                         gfc_index_zero_node,
 886                                         gfc_rank_cst[dimen - 1]));
 887
 888   decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
 889   DECL_CONTEXT (decl) = fat_type;
 890   DECL_INITIAL (decl) = NULL_TREE;
 891   fieldlist = chainon (fieldlist, decl);
 892
 893   /* Finish off the type.  */
 894   TYPE_FIELDS (fat_type) = fieldlist;
 895
 896   gfc_finish_type (fat_type);
 897
 898   return fat_type;
 899 }
 900 \f
 901 /* Build a pointer type. This function is called from gfc_sym_type().  */
 902
 903 static tree
 904 gfc_build_pointer_type (gfc_symbol * sym, tree type)
 905 {
 906
 907   /* Array pointer types aren't actually pointers.  */
 908   if (sym->attr.dimension)
 909     return type;
 910   else
 911     return build_pointer_type (type);
 912 }
 913 \f
 914 /* Return the type for a symbol.  Special handling is required for character
 915    types to get the correct level of indirection.
 916    For functions return the return type.
 917    For subroutines return void_type_node.
 918    Calling this multiple times for the same symbol should be avoided,
 919    especially for character and array types.  */
 920
 921 tree
 922 gfc_sym_type (gfc_symbol * sym)
 923 {
 924   tree type;
 925   int byref;
 926
 927   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
 928     return void_type_node;
 929
 930   if (sym->backend_decl)
 931     {
 932       if (sym->attr.function)
 933         return TREE_TYPE (TREE_TYPE (sym->backend_decl));
 934       else
 935         return TREE_TYPE (sym->backend_decl);
 936     }
 937
 938   /* The frontend doesn't set all the attributes for a function with an
 939      explicit result value, so we use that instead when present.  */
 940   if (sym->attr.function && sym->result)
 941     sym = sym->result;
 942
 943   type = gfc_typenode_for_spec (&sym->ts);
 944
 945   if (sym->attr.dummy && !sym->attr.function)
 946     byref = 1;
 947   else
 948     byref = 0;
 949
 950   if (sym->attr.dimension)
 951     {
 952       if (gfc_is_nodesc_array (sym))
 953         {
 954           /* If this is a character argument of unknown length, just use the
 955              base type.  */
 956           if (sym->ts.type != BT_CHARACTER
 957               || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
 958               || sym->ts.cl->backend_decl)
 959             {
 960               type = gfc_get_nodesc_array_type (type, sym->as,
 961                                                 byref ? 2 : 3);
 962               byref = 0;
 963             }
 964         }
 965       else
 966         type = gfc_build_array_type (type, sym->as);
 967     }
 968   else
 969     {
 970       if (sym->attr.allocatable || sym->attr.pointer)
 971         type = gfc_build_pointer_type (sym, type);
 972     }
 973
 974   /* We currently pass all parameters by reference.
 975      See f95_get_function_decl.  For dummy function parameters return the
 976      function type.  */
 977   if (byref)
 978     {
 979       /* We must use pointer types for potentially absent variables.  The
 980          optimizers assume a reference type argument is never NULL.  */
 981       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
 982         type = build_pointer_type (type);
 983       else
 984         type = build_reference_type (type);
 985     }
 986
 987   return (type);
 988 }
 989 \f
 990 /* Layout and output debug info for a record type.  */
 991
 992 void
 993 gfc_finish_type (tree type)
 994 {
 995   tree decl;
 996
 997   decl = build_decl (TYPE_DECL, NULL_TREE, type);
 998   TYPE_STUB_DECL (type) = decl;
 999   layout_type (type);
1000   rest_of_type_compilation (type, 1);
1001   rest_of_decl_compilation (decl, 1, 0);
1002 }
1003 \f
1004 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1005    or RECORD_TYPE pointed to by STYPE.  The new field is chained
1006    to the fieldlist pointed to by FIELDLIST.
1007
1008    Returns a pointer to the new field.  */
1009
1010 tree
1011 gfc_add_field_to_struct (tree *fieldlist, tree context,
1012                          tree name, tree type)
1013 {
1014   tree decl;
1015
1016   decl = build_decl (FIELD_DECL, name, type);
1017
1018   DECL_CONTEXT (decl) = context;
1019   DECL_INITIAL (decl) = 0;
1020   DECL_ALIGN (decl) = 0;
1021   DECL_USER_ALIGN (decl) = 0;
1022   TREE_CHAIN (decl) = NULL_TREE;
1023   *fieldlist = chainon (*fieldlist, decl);
1024
1025   return decl;
1026 }
1027
1028
1029 /* Build a tree node for a derived type.  */
1030
1031 static tree
1032 gfc_get_derived_type (gfc_symbol * derived)
1033 {
1034   tree typenode, field, field_type, fieldlist;
1035   gfc_component *c;
1036
1037   assert (derived && derived->attr.flavor == FL_DERIVED);
1038
1039   /* derived->backend_decl != 0 means we saw it before, but its
1040      components' backend_decl may have not been built.  */
1041   if (derived->backend_decl)
1042     {
1043       /* Its components' backend_decl have been built.  */
1044       if (TYPE_FIELDS (derived->backend_decl))
1045         return derived->backend_decl;
1046       else
1047         typenode = derived->backend_decl;
1048     }
1049   else
1050     {
1051       /* We see this derived type first time, so build the type node.  */
1052       typenode = make_node (RECORD_TYPE);
1053       TYPE_NAME (typenode) = get_identifier (derived->name);
1054       TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1055       derived->backend_decl = typenode;
1056     }
1057
1058   /* Build the type member list. Install the newly created RECORD_TYPE
1059      node as DECL_CONTEXT of each FIELD_DECL.  */
1060   fieldlist = NULL_TREE;
1061   for (c = derived->components; c; c = c->next)
1062     {
1063       if (c->ts.type == BT_DERIVED && c->pointer)
1064         {
1065           if (c->ts.derived->backend_decl)
1066             field_type = c->ts.derived->backend_decl;
1067           else
1068             {
1069               /* Build the type node.  */
1070               field_type = make_node (RECORD_TYPE);
1071               TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1072               TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1073               c->ts.derived->backend_decl = field_type;
1074             }
1075         }
1076       else
1077         {
1078           if (c->ts.type == BT_CHARACTER)
1079             {
1080               /* Evaluate the string length.  */
1081               gfc_conv_const_charlen (c->ts.cl);
1082               assert (c->ts.cl->backend_decl);
1083             }
1084
1085           field_type = gfc_typenode_for_spec (&c->ts);
1086         }
1087
1088       /* This returns an array descriptor type.  Initialisation may be
1089          required.  */
1090       if (c->dimension)
1091         {
1092           if (c->pointer)
1093             {
1094               /* Pointers to arrays aren't actualy pointer types.  The
1095                  descriptors are seperate, but the data is common.  */
1096               field_type = gfc_build_array_type (field_type, c->as);
1097             }
1098           else
1099             field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1100         }
1101       else if (c->pointer)
1102         field_type = build_pointer_type (field_type);
1103
1104       field = gfc_add_field_to_struct (&fieldlist, typenode,
1105                                        get_identifier (c->name),
1106                                        field_type);
1107
1108       DECL_PACKED (field) |= TYPE_PACKED (typenode);
1109
1110       assert (!c->backend_decl);
1111       c->backend_decl = field;
1112     }
1113
1114   /* Now we have the final fieldlist.  Record it, then lay out the
1115      derived type, including the fields.  */
1116   TYPE_FIELDS (typenode) = fieldlist;
1117
1118   gfc_finish_type (typenode);
1119
1120   derived->backend_decl = typenode;
1121
1122   return typenode;
1123 }
1124 \f
1125 int
1126 gfc_return_by_reference (gfc_symbol * sym)
1127 {
1128   if (!sym->attr.function)
1129     return 0;
1130
1131   assert (sym->attr.function);
1132
1133   if (sym->result)
1134     sym = sym->result;
1135
1136   if (sym->attr.dimension)
1137     return 1;
1138
1139   if (sym->ts.type == BT_CHARACTER)
1140     return 1;
1141
1142   if (sym->ts.type == BT_DERIVED)
1143     gfc_todo_error ("Returning derived types");
1144   /* Possibly return derived types by reference.  */
1145   return 0;
1146 }
1147 \f
1148 tree
1149 gfc_get_function_type (gfc_symbol * sym)
1150 {
1151   tree type;
1152   tree typelist;
1153   gfc_formal_arglist *f;
1154   gfc_symbol *arg;
1155   int nstr;
1156   int alternate_return;
1157
1158   /* Make sure this symbol is a function or a subroutine.  */
1159   assert (sym->attr.flavor == FL_PROCEDURE);
1160
1161   if (sym->backend_decl)
1162     return TREE_TYPE (sym->backend_decl);
1163
1164   nstr = 0;
1165   alternate_return = 0;
1166   typelist = NULL_TREE;
1167
1168   if (sym->attr.entry_master)
1169     {
1170       /* Additional parameter for selecting an entry point.  */
1171       typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1172     }
1173
1174   /* Some functions we use an extra parameter for the return value.  */
1175   if (gfc_return_by_reference (sym))
1176     {
1177       if (sym->result)
1178         arg = sym->result;
1179       else
1180         arg = sym;
1181
1182       if (arg->ts.type == BT_CHARACTER)
1183         gfc_conv_const_charlen (arg->ts.cl);
1184
1185       type = gfc_sym_type (arg);
1186       if (arg->ts.type == BT_DERIVED
1187           || arg->attr.dimension
1188           || arg->ts.type == BT_CHARACTER)
1189         type = build_reference_type (type);
1190
1191       typelist = gfc_chainon_list (typelist, type);
1192       if (arg->ts.type == BT_CHARACTER)
1193         typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1194     }
1195
1196   /* Build the argument types for the function.  */
1197   for (f = sym->formal; f; f = f->next)
1198     {
1199       arg = f->sym;
1200       if (arg)
1201         {
1202           /* Evaluate constant character lengths here so that they can be
1203              included in the type.  */
1204           if (arg->ts.type == BT_CHARACTER)
1205             gfc_conv_const_charlen (arg->ts.cl);
1206
1207           if (arg->attr.flavor == FL_PROCEDURE)
1208             {
1209               type = gfc_get_function_type (arg);
1210               type = build_pointer_type (type);
1211             }
1212           else
1213             type = gfc_sym_type (arg);
1214
1215           /* Parameter Passing Convention
1216
1217              We currently pass all parameters by reference.
1218              Parameters with INTENT(IN) could be passed by value.
1219              The problem arises if a function is called via an implicit
1220              prototype. In this situation the INTENT is not known.
1221              For this reason all parameters to global functions must be
1222              passed by reference.  Passing by value would potentialy
1223              generate bad code.  Worse there would be no way of telling that
1224              this code was bad, except that it would give incorrect results.
1225
1226              Contained procedures could pass by value as these are never
1227              used without an explicit interface, and connot be passed as
1228              actual parameters for a dummy procedure.  */
1229           if (arg->ts.type == BT_CHARACTER)
1230             nstr++;
1231           typelist = gfc_chainon_list (typelist, type);
1232         }
1233       else
1234         {
1235           if (sym->attr.subroutine)
1236             alternate_return = 1;
1237         }
1238     }
1239
1240   /* Add hidden string length parameters.  */
1241   while (nstr--)
1242     typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1243
1244   typelist = gfc_chainon_list (typelist, void_type_node);
1245
1246   if (alternate_return)
1247     type = integer_type_node;
1248   else if (!sym->attr.function || gfc_return_by_reference (sym))
1249     type = void_type_node;
1250   else
1251     type = gfc_sym_type (sym);
1252
1253   type = build_function_type (type, typelist);
1254
1255   return type;
1256 }
1257 \f
1258 /* Routines for getting integer type nodes.  */
1259
1260
1261 /* Return an integer type with BITS bits of precision,
1262    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
1263
1264 tree
1265 gfc_type_for_size (unsigned bits, int unsignedp)
1266 {
1267   if (bits == TYPE_PRECISION (integer_type_node))
1268     return unsignedp ? unsigned_type_node : integer_type_node;
1269
1270   if (bits == TYPE_PRECISION (signed_char_type_node))
1271     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1272
1273   if (bits == TYPE_PRECISION (short_integer_type_node))
1274     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1275
1276   if (bits == TYPE_PRECISION (long_integer_type_node))
1277     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1278
1279   if (bits == TYPE_PRECISION (long_long_integer_type_node))
1280     return (unsignedp ? long_long_unsigned_type_node
1281             : long_long_integer_type_node);
1282 /*TODO: We currently don't initialise this...
1283   if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1284     return (unsignedp ? widest_unsigned_literal_type_node
1285             : widest_integer_literal_type_node);*/
1286
1287   if (bits <= TYPE_PRECISION (intQI_type_node))
1288     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1289
1290   if (bits <= TYPE_PRECISION (intHI_type_node))
1291     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1292
1293   if (bits <= TYPE_PRECISION (intSI_type_node))
1294     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1295
1296   if (bits <= TYPE_PRECISION (intDI_type_node))
1297     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1298
1299   return 0;
1300 }
1301
1302 /* Return a data type that has machine mode MODE.
1303    If the mode is an integer,
1304    then UNSIGNEDP selects between signed and unsigned types.  */
1305
1306 tree
1307 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1308 {
1309   if (mode == TYPE_MODE (integer_type_node))
1310     return unsignedp ? unsigned_type_node : integer_type_node;
1311
1312   if (mode == TYPE_MODE (signed_char_type_node))
1313     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1314
1315   if (mode == TYPE_MODE (short_integer_type_node))
1316     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1317
1318   if (mode == TYPE_MODE (long_integer_type_node))
1319     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1320
1321   if (mode == TYPE_MODE (long_long_integer_type_node))
1322     return unsignedp ? long_long_unsigned_type_node :
1323       long_long_integer_type_node;
1324
1325 /*TODO: see above
1326   if (mode == TYPE_MODE (widest_integer_literal_type_node))
1327     return unsignedp ? widest_unsigned_literal_type_node
1328                      : widest_integer_literal_type_node;
1329 */
1330
1331   if (mode == QImode)
1332     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1333
1334   if (mode == HImode)
1335     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1336
1337   if (mode == SImode)
1338     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1339
1340   if (mode == DImode)
1341     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1342
1343 #if HOST_BITS_PER_WIDE_INT >= 64
1344   if (mode == TYPE_MODE (intTI_type_node))
1345     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1346 #endif
1347
1348   if (mode == TYPE_MODE (float_type_node))
1349     return float_type_node;
1350
1351   if (mode == TYPE_MODE (double_type_node))
1352     return double_type_node;
1353
1354   if (mode == TYPE_MODE (long_double_type_node))
1355     return long_double_type_node;
1356
1357   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1358     return build_pointer_type (char_type_node);
1359
1360   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1361     return build_pointer_type (integer_type_node);
1362
1363   if (VECTOR_MODE_P (mode))
1364     {
1365       enum machine_mode inner_mode = GET_MODE_INNER (mode);
1366       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1367       if (inner_type != NULL_TREE)
1368         return build_vector_type_for_mode (inner_type, mode);
1369     }
1370
1371   return 0;
1372 }
1373
1374 /* Return an unsigned type the same as TYPE in other respects.  */
1375
1376 tree
1377 gfc_unsigned_type (tree type)
1378 {
1379   tree type1 = TYPE_MAIN_VARIANT (type);
1380   if (type1 == signed_char_type_node || type1 == char_type_node)
1381     return unsigned_char_type_node;
1382   if (type1 == integer_type_node)
1383     return unsigned_type_node;
1384   if (type1 == short_integer_type_node)
1385     return short_unsigned_type_node;
1386   if (type1 == long_integer_type_node)
1387     return long_unsigned_type_node;
1388   if (type1 == long_long_integer_type_node)
1389     return long_long_unsigned_type_node;
1390 /*TODO :see others
1391   if (type1 == widest_integer_literal_type_node)
1392     return widest_unsigned_literal_type_node;
1393 */
1394 #if HOST_BITS_PER_WIDE_INT >= 64
1395   if (type1 == intTI_type_node)
1396     return unsigned_intTI_type_node;
1397 #endif
1398   if (type1 == intDI_type_node)
1399     return unsigned_intDI_type_node;
1400   if (type1 == intSI_type_node)
1401     return unsigned_intSI_type_node;
1402   if (type1 == intHI_type_node)
1403     return unsigned_intHI_type_node;
1404   if (type1 == intQI_type_node)
1405     return unsigned_intQI_type_node;
1406
1407   return gfc_signed_or_unsigned_type (1, type);
1408 }
1409
1410 /* Return a signed type the same as TYPE in other respects.  */
1411
1412 tree
1413 gfc_signed_type (tree type)
1414 {
1415   tree type1 = TYPE_MAIN_VARIANT (type);
1416   if (type1 == unsigned_char_type_node || type1 == char_type_node)
1417     return signed_char_type_node;
1418   if (type1 == unsigned_type_node)
1419     return integer_type_node;
1420   if (type1 == short_unsigned_type_node)
1421     return short_integer_type_node;
1422   if (type1 == long_unsigned_type_node)
1423     return long_integer_type_node;
1424   if (type1 == long_long_unsigned_type_node)
1425     return long_long_integer_type_node;
1426 /*TODO: see others
1427   if (type1 == widest_unsigned_literal_type_node)
1428     return widest_integer_literal_type_node;
1429 */
1430 #if HOST_BITS_PER_WIDE_INT >= 64
1431   if (type1 == unsigned_intTI_type_node)
1432     return intTI_type_node;
1433 #endif
1434   if (type1 == unsigned_intDI_type_node)
1435     return intDI_type_node;
1436   if (type1 == unsigned_intSI_type_node)
1437     return intSI_type_node;
1438   if (type1 == unsigned_intHI_type_node)
1439     return intHI_type_node;
1440   if (type1 == unsigned_intQI_type_node)
1441     return intQI_type_node;
1442
1443   return gfc_signed_or_unsigned_type (0, type);
1444 }
1445
1446 /* Return a type the same as TYPE except unsigned or
1447    signed according to UNSIGNEDP.  */
1448
1449 tree
1450 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1451 {
1452   if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1453     return type;
1454
1455   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1456     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1457   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1458     return unsignedp ? unsigned_type_node : integer_type_node;
1459   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1460     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1461   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1462     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1463   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1464     return (unsignedp ? long_long_unsigned_type_node
1465             : long_long_integer_type_node);
1466 /*TODO: see others
1467   if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1468     return (unsignedp ? widest_unsigned_literal_type_node
1469             : widest_integer_literal_type_node);
1470 */
1471 #if HOST_BITS_PER_WIDE_INT >= 64
1472   if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1473     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1474 #endif
1475   if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1476     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1477   if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1478     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1479   if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1480     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1481   if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1482     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1483
1484   return type;
1485 }
1486
1487 #include "gt-fortran-trans-types.h"