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   /* Array pointer types aren't actually pointers.  */
 907   if (sym->attr.dimension)
 908     return type;
 909   else
 910     return build_pointer_type (type);
 911 }
 912 \f
 913 /* Return the type for a symbol.  Special handling is required for character
 914    types to get the correct level of indirection.
 915    For functions return the return type.
 916    For subroutines return void_type_node.
 917    Calling this multiple times for the same symbol should be avoided,
 918    especially for character and array types.  */
 919
 920 tree
 921 gfc_sym_type (gfc_symbol * sym)
 922 {
 923   tree type;
 924   int byref;
 925
 926   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
 927     return void_type_node;
 928
 929   if (sym->backend_decl)
 930     {
 931       if (sym->attr.function)
 932         return TREE_TYPE (TREE_TYPE (sym->backend_decl));
 933       else
 934         return TREE_TYPE (sym->backend_decl);
 935     }
 936
 937   /* The frontend doesn't set all the attributes for a function with an
 938      explicit result value, so we use that instead when present.  */
 939   if (sym->attr.function && sym->result)
 940     sym = sym->result;
 941
 942   type = gfc_typenode_for_spec (&sym->ts);
 943
 944   if (sym->attr.dummy && !sym->attr.function)
 945     byref = 1;
 946   else
 947     byref = 0;
 948
 949   if (sym->attr.dimension)
 950     {
 951       if (gfc_is_nodesc_array (sym))
 952         {
 953           /* If this is a character argument of unknown length, just use the
 954              base type.  */
 955           if (sym->ts.type != BT_CHARACTER
 956               || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
 957               || sym->ts.cl->backend_decl)
 958             {
 959               type = gfc_get_nodesc_array_type (type, sym->as,
 960                                                 byref ? 2 : 3);
 961               byref = 0;
 962             }
 963         }
 964       else
 965         type = gfc_build_array_type (type, sym->as);
 966     }
 967   else
 968     {
 969       if (sym->attr.allocatable || sym->attr.pointer)
 970         type = gfc_build_pointer_type (sym, type);
 971     }
 972
 973   /* We currently pass all parameters by reference.
 974      See f95_get_function_decl.  For dummy function parameters return the
 975      function type.  */
 976   if (byref)
 977     {
 978       /* We must use pointer types for potentially absent variables.  The
 979          optimizers assume a reference type argument is never NULL.  */
 980       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
 981         type = build_pointer_type (type);
 982       else
 983         type = build_reference_type (type);
 984     }
 985
 986   return (type);
 987 }
 988 \f
 989 /* Layout and output debug info for a record type.  */
 990
 991 void
 992 gfc_finish_type (tree type)
 993 {
 994   tree decl;
 995
 996   decl = build_decl (TYPE_DECL, NULL_TREE, type);
 997   TYPE_STUB_DECL (type) = decl;
 998   layout_type (type);
 999   rest_of_type_compilation (type, 1);
1000   rest_of_decl_compilation (decl, 1, 0);
1001 }
1002 \f
1003 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1004    or RECORD_TYPE pointed to by STYPE.  The new field is chained
1005    to the fieldlist pointed to by FIELDLIST.
1006
1007    Returns a pointer to the new field.  */
1008
1009 tree
1010 gfc_add_field_to_struct (tree *fieldlist, tree context,
1011                          tree name, tree type)
1012 {
1013   tree decl;
1014
1015   decl = build_decl (FIELD_DECL, name, type);
1016
1017   DECL_CONTEXT (decl) = context;
1018   DECL_INITIAL (decl) = 0;
1019   DECL_ALIGN (decl) = 0;
1020   DECL_USER_ALIGN (decl) = 0;
1021   TREE_CHAIN (decl) = NULL_TREE;
1022   *fieldlist = chainon (*fieldlist, decl);
1023
1024   return decl;
1025 }
1026
1027
1028 /* Build a tree node for a derived type.  */
1029
1030 static tree
1031 gfc_get_derived_type (gfc_symbol * derived)
1032 {
1033   tree typenode, field, field_type, fieldlist;
1034   gfc_component *c;
1035
1036   assert (derived && derived->attr.flavor == FL_DERIVED);
1037
1038   /* derived->backend_decl != 0 means we saw it before, but its
1039      components' backend_decl may have not been built.  */
1040   if (derived->backend_decl)
1041     {
1042       /* Its components' backend_decl have been built.  */
1043       if (TYPE_FIELDS (derived->backend_decl))
1044         return derived->backend_decl;
1045       else
1046         typenode = derived->backend_decl;
1047     }
1048   else
1049     {
1050       /* We see this derived type first time, so build the type node.  */
1051       typenode = make_node (RECORD_TYPE);
1052       TYPE_NAME (typenode) = get_identifier (derived->name);
1053       TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1054       derived->backend_decl = typenode;
1055     }
1056
1057   /* Build the type member list. Install the newly created RECORD_TYPE
1058      node as DECL_CONTEXT of each FIELD_DECL.  */
1059   fieldlist = NULL_TREE;
1060   for (c = derived->components; c; c = c->next)
1061     {
1062       if (c->ts.type == BT_DERIVED && c->pointer)
1063         {
1064           if (c->ts.derived->backend_decl)
1065             field_type = c->ts.derived->backend_decl;
1066           else
1067             {
1068               /* Build the type node.  */
1069               field_type = make_node (RECORD_TYPE);
1070               TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1071               TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1072               c->ts.derived->backend_decl = field_type;
1073             }
1074         }
1075       else
1076         {
1077           if (c->ts.type == BT_CHARACTER)
1078             {
1079               /* Evaluate the string length.  */
1080               gfc_conv_const_charlen (c->ts.cl);
1081               assert (c->ts.cl->backend_decl);
1082             }
1083
1084           field_type = gfc_typenode_for_spec (&c->ts);
1085         }
1086
1087       /* This returns an array descriptor type.  Initialisation may be
1088          required.  */
1089       if (c->dimension)
1090         {
1091           if (c->pointer)
1092             {
1093               /* Pointers to arrays aren't actualy pointer types.  The
1094                  descriptors are seperate, but the data is common.  */
1095               field_type = gfc_build_array_type (field_type, c->as);
1096             }
1097           else
1098             field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1099         }
1100       else if (c->pointer)
1101         field_type = build_pointer_type (field_type);
1102
1103       field = gfc_add_field_to_struct (&fieldlist, typenode,
1104                                        get_identifier (c->name),
1105                                        field_type);
1106
1107       DECL_PACKED (field) |= TYPE_PACKED (typenode);
1108
1109       assert (!c->backend_decl);
1110       c->backend_decl = field;
1111     }
1112
1113   /* Now we have the final fieldlist.  Record it, then lay out the
1114      derived type, including the fields.  */
1115   TYPE_FIELDS (typenode) = fieldlist;
1116
1117   gfc_finish_type (typenode);
1118
1119   derived->backend_decl = typenode;
1120
1121   return typenode;
1122 }
1123 \f
1124 int
1125 gfc_return_by_reference (gfc_symbol * sym)
1126 {
1127   if (!sym->attr.function)
1128     return 0;
1129
1130   assert (sym->attr.function);
1131
1132   if (sym->result)
1133     sym = sym->result;
1134
1135   if (sym->attr.dimension)
1136     return 1;
1137
1138   if (sym->ts.type == BT_CHARACTER)
1139     return 1;
1140
1141   if (sym->ts.type == BT_DERIVED)
1142     gfc_todo_error ("Returning derived types");
1143   /* Possibly return derived types by reference.  */
1144   return 0;
1145 }
1146 \f
1147 tree
1148 gfc_get_function_type (gfc_symbol * sym)
1149 {
1150   tree type;
1151   tree typelist;
1152   gfc_formal_arglist *f;
1153   gfc_symbol *arg;
1154   int nstr;
1155   int alternate_return;
1156
1157   /* Make sure this symbol is a function or a subroutine.  */
1158   assert (sym->attr.flavor == FL_PROCEDURE);
1159
1160   if (sym->backend_decl)
1161     return TREE_TYPE (sym->backend_decl);
1162
1163   nstr = 0;
1164   alternate_return = 0;
1165   typelist = NULL_TREE;
1166
1167   if (sym->attr.entry_master)
1168     {
1169       /* Additional parameter for selecting an entry point.  */
1170       typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1171     }
1172
1173   /* Some functions we use an extra parameter for the return value.  */
1174   if (gfc_return_by_reference (sym))
1175     {
1176       if (sym->result)
1177         arg = sym->result;
1178       else
1179         arg = sym;
1180
1181       if (arg->ts.type == BT_CHARACTER)
1182         gfc_conv_const_charlen (arg->ts.cl);
1183
1184       type = gfc_sym_type (arg);
1185       if (arg->ts.type == BT_DERIVED
1186           || arg->attr.dimension
1187           || arg->ts.type == BT_CHARACTER)
1188         type = build_reference_type (type);
1189
1190       typelist = gfc_chainon_list (typelist, type);
1191       if (arg->ts.type == BT_CHARACTER)
1192         typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1193     }
1194
1195   /* Build the argument types for the function.  */
1196   for (f = sym->formal; f; f = f->next)
1197     {
1198       arg = f->sym;
1199       if (arg)
1200         {
1201           /* Evaluate constant character lengths here so that they can be
1202              included in the type.  */
1203           if (arg->ts.type == BT_CHARACTER)
1204             gfc_conv_const_charlen (arg->ts.cl);
1205
1206           if (arg->attr.flavor == FL_PROCEDURE)
1207             {
1208               type = gfc_get_function_type (arg);
1209               type = build_pointer_type (type);
1210             }
1211           else
1212             type = gfc_sym_type (arg);
1213
1214           /* Parameter Passing Convention
1215
1216              We currently pass all parameters by reference.
1217              Parameters with INTENT(IN) could be passed by value.
1218              The problem arises if a function is called via an implicit
1219              prototype. In this situation the INTENT is not known.
1220              For this reason all parameters to global functions must be
1221              passed by reference.  Passing by value would potentialy
1222              generate bad code.  Worse there would be no way of telling that
1223              this code was bad, except that it would give incorrect results.
1224
1225              Contained procedures could pass by value as these are never
1226              used without an explicit interface, and connot be passed as
1227              actual parameters for a dummy procedure.  */
1228           if (arg->ts.type == BT_CHARACTER)
1229             nstr++;
1230           typelist = gfc_chainon_list (typelist, type);
1231         }
1232       else
1233         {
1234           if (sym->attr.subroutine)
1235             alternate_return = 1;
1236         }
1237     }
1238
1239   /* Add hidden string length parameters.  */
1240   while (nstr--)
1241     typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1242
1243   typelist = gfc_chainon_list (typelist, void_type_node);
1244
1245   if (alternate_return)
1246     type = integer_type_node;
1247   else if (!sym->attr.function || gfc_return_by_reference (sym))
1248     type = void_type_node;
1249   else
1250     type = gfc_sym_type (sym);
1251
1252   type = build_function_type (type, typelist);
1253
1254   return type;
1255 }
1256 \f
1257 /* Routines for getting integer type nodes.  */
1258
1259
1260 /* Return an integer type with BITS bits of precision,
1261    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
1262
1263 tree
1264 gfc_type_for_size (unsigned bits, int unsignedp)
1265 {
1266   if (bits == TYPE_PRECISION (integer_type_node))
1267     return unsignedp ? unsigned_type_node : integer_type_node;
1268
1269   if (bits == TYPE_PRECISION (signed_char_type_node))
1270     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1271
1272   if (bits == TYPE_PRECISION (short_integer_type_node))
1273     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1274
1275   if (bits == TYPE_PRECISION (long_integer_type_node))
1276     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1277
1278   if (bits == TYPE_PRECISION (long_long_integer_type_node))
1279     return (unsignedp ? long_long_unsigned_type_node
1280             : long_long_integer_type_node);
1281 /*TODO: We currently don't initialise this...
1282   if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1283     return (unsignedp ? widest_unsigned_literal_type_node
1284             : widest_integer_literal_type_node);*/
1285
1286   if (bits <= TYPE_PRECISION (intQI_type_node))
1287     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1288
1289   if (bits <= TYPE_PRECISION (intHI_type_node))
1290     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1291
1292   if (bits <= TYPE_PRECISION (intSI_type_node))
1293     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1294
1295   if (bits <= TYPE_PRECISION (intDI_type_node))
1296     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1297
1298   return 0;
1299 }
1300
1301 /* Return a data type that has machine mode MODE.
1302    If the mode is an integer,
1303    then UNSIGNEDP selects between signed and unsigned types.  */
1304
1305 tree
1306 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1307 {
1308   if (mode == TYPE_MODE (integer_type_node))
1309     return unsignedp ? unsigned_type_node : integer_type_node;
1310
1311   if (mode == TYPE_MODE (signed_char_type_node))
1312     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1313
1314   if (mode == TYPE_MODE (short_integer_type_node))
1315     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1316
1317   if (mode == TYPE_MODE (long_integer_type_node))
1318     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1319
1320   if (mode == TYPE_MODE (long_long_integer_type_node))
1321     return unsignedp ? long_long_unsigned_type_node :
1322       long_long_integer_type_node;
1323
1324 /*TODO: see above
1325   if (mode == TYPE_MODE (widest_integer_literal_type_node))
1326     return unsignedp ? widest_unsigned_literal_type_node
1327                      : widest_integer_literal_type_node;
1328 */
1329
1330   if (mode == QImode)
1331     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1332
1333   if (mode == HImode)
1334     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1335
1336   if (mode == SImode)
1337     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1338
1339   if (mode == DImode)
1340     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1341
1342 #if HOST_BITS_PER_WIDE_INT >= 64
1343   if (mode == TYPE_MODE (intTI_type_node))
1344     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1345 #endif
1346
1347   if (mode == TYPE_MODE (float_type_node))
1348     return float_type_node;
1349
1350   if (mode == TYPE_MODE (double_type_node))
1351     return double_type_node;
1352
1353   if (mode == TYPE_MODE (long_double_type_node))
1354     return long_double_type_node;
1355
1356   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1357     return build_pointer_type (char_type_node);
1358
1359   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1360     return build_pointer_type (integer_type_node);
1361
1362   if (VECTOR_MODE_P (mode))
1363     {
1364       enum machine_mode inner_mode = GET_MODE_INNER (mode);
1365       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1366       if (inner_type != NULL_TREE)
1367         return build_vector_type_for_mode (inner_type, mode);
1368     }
1369
1370   return 0;
1371 }
1372
1373 /* Return an unsigned type the same as TYPE in other respects.  */
1374
1375 tree
1376 gfc_unsigned_type (tree type)
1377 {
1378   tree type1 = TYPE_MAIN_VARIANT (type);
1379
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
1417   if (type1 == unsigned_char_type_node || type1 == char_type_node)
1418     return signed_char_type_node;
1419   if (type1 == unsigned_type_node)
1420     return integer_type_node;
1421   if (type1 == short_unsigned_type_node)
1422     return short_integer_type_node;
1423   if (type1 == long_unsigned_type_node)
1424     return long_integer_type_node;
1425   if (type1 == long_long_unsigned_type_node)
1426     return long_long_integer_type_node;
1427 /*TODO: see others
1428   if (type1 == widest_unsigned_literal_type_node)
1429     return widest_integer_literal_type_node;
1430 */
1431 #if HOST_BITS_PER_WIDE_INT >= 64
1432   if (type1 == unsigned_intTI_type_node)
1433     return intTI_type_node;
1434 #endif
1435   if (type1 == unsigned_intDI_type_node)
1436     return intDI_type_node;
1437   if (type1 == unsigned_intSI_type_node)
1438     return intSI_type_node;
1439   if (type1 == unsigned_intHI_type_node)
1440     return intHI_type_node;
1441   if (type1 == unsigned_intQI_type_node)
1442     return intQI_type_node;
1443
1444   return gfc_signed_or_unsigned_type (0, type);
1445 }
1446
1447 /* Return a type the same as TYPE except unsigned or
1448    signed according to UNSIGNEDP.  */
1449
1450 tree
1451 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1452 {
1453   if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1454     return type;
1455
1456   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1457     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1458   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1459     return unsignedp ? unsigned_type_node : integer_type_node;
1460   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1461     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1462   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1463     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1464   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1465     return (unsignedp ? long_long_unsigned_type_node
1466             : long_long_integer_type_node);
1467 /*TODO: see others
1468   if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1469     return (unsignedp ? widest_unsigned_literal_type_node
1470             : widest_integer_literal_type_node);
1471 */
1472 #if HOST_BITS_PER_WIDE_INT >= 64
1473   if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1474     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1475 #endif
1476   if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1477     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1478   if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1479     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1480   if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1481     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1482   if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1483     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1484
1485   return type;
1486 }
1487
1488 #include "gt-fortran-trans-types.h"