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   switch (kind)
 230     {
 231     case 4:
 232       return (gfc_complex4_type_node);
 233     case 8:
 234       return (gfc_complex8_type_node);
 235 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 236     case 16:
 237       return (gfc_complex16_type_node);
 238 #endif
 239     default:
 240       fatal_error ("complex kind=%d not available", kind);
 241     }
 242 }
 243
 244 /* Get a type node for a logical kind */
 245
 246 tree
 247 gfc_get_logical_type (int kind)
 248 {
 249   switch (kind)
 250     {
 251     case 1:
 252       return (gfc_logical1_type_node);
 253     case 2:
 254       return (gfc_logical2_type_node);
 255     case 4:
 256       return (gfc_logical4_type_node);
 257     case 8:
 258       return (gfc_logical8_type_node);
 259 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
 260     case 16:
 261       return (gfc_logical16_type_node);
 262 #endif
 263     default:
 264       fatal_error ("logical kind=%d not available", kind);
 265     }
 266 }
 267 \f
 268 /* Get a type node for a character kind.  */
 269
 270 tree
 271 gfc_get_character_type (int kind, gfc_charlen * cl)
 272 {
 273   tree base;
 274   tree type;
 275   tree len;
 276   tree bounds;
 277
 278   switch (kind)
 279     {
 280     case 1:
 281       base = gfc_character1_type_node;
 282       break;
 283
 284     default:
 285       fatal_error ("character kind=%d not available", kind);
 286     }
 287
 288   len = (cl == 0) ? NULL_TREE : cl->backend_decl;
 289
 290   bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
 291   type = build_array_type (base, bounds);
 292   TYPE_STRING_FLAG (type) = 1;
 293
 294   return type;
 295 }
 296 \f
 297 /* Covert a basic type.  This will be an array for character types.  */
 298
 299 tree
 300 gfc_typenode_for_spec (gfc_typespec * spec)
 301 {
 302   tree basetype;
 303
 304   switch (spec->type)
 305     {
 306     case BT_UNKNOWN:
 307       abort ();
 308       break;
 309
 310     case BT_INTEGER:
 311       basetype = gfc_get_int_type (spec->kind);
 312       break;
 313
 314     case BT_REAL:
 315       basetype = gfc_get_real_type (spec->kind);
 316       break;
 317
 318     case BT_COMPLEX:
 319       basetype = gfc_get_complex_type (spec->kind);
 320       break;
 321
 322     case BT_LOGICAL:
 323       basetype = gfc_get_logical_type (spec->kind);
 324       break;
 325
 326     case BT_CHARACTER:
 327       basetype = gfc_get_character_type (spec->kind, spec->cl);
 328       break;
 329
 330     case BT_DERIVED:
 331       basetype = gfc_get_derived_type (spec->derived);
 332       break;
 333
 334     default:
 335       abort ();
 336       break;
 337     }
 338   return basetype;
 339 }
 340 \f
 341 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */
 342
 343 static tree
 344 gfc_conv_array_bound (gfc_expr * expr)
 345 {
 346   /* If expr is an integer constant, return that.  */
 347   if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
 348     return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
 349
 350   /* Otherwise return NULL.  */
 351   return NULL_TREE;
 352 }
 353 \f
 354 tree
 355 gfc_get_element_type (tree type)
 356 {
 357   tree element;
 358
 359   if (GFC_ARRAY_TYPE_P (type))
 360     {
 361       if (TREE_CODE (type) == POINTER_TYPE)
 362         type = TREE_TYPE (type);
 363       assert (TREE_CODE (type) == ARRAY_TYPE);
 364       element = TREE_TYPE (type);
 365     }
 366   else
 367     {
 368       assert (GFC_DESCRIPTOR_TYPE_P (type));
 369       element = TREE_TYPE (TYPE_FIELDS (type));
 370
 371       assert (TREE_CODE (element) == POINTER_TYPE);
 372       element = TREE_TYPE (element);
 373
 374       assert (TREE_CODE (element) == ARRAY_TYPE);
 375       element = TREE_TYPE (element);
 376     }
 377
 378   return element;
 379 }
 380 \f
 381 /* Build an array. This function is called from gfc_sym_type().
 382    Actually returns array descriptor type.
 383
 384    Format of array descriptors is as follows:
 385
 386     struct gfc_array_descriptor
 387     {
 388       array *data
 389       index offset;
 390       index dtype;
 391       struct descriptor_dimension dimension[N_DIM];
 392     }
 393
 394     struct descriptor_dimension
 395     {
 396       index stride;
 397       index lbound;
 398       index ubound;
 399     }
 400
 401    Translation code should use gfc_conv_descriptor_* rather than accessing
 402    the descriptor directly. Any changes to the array descriptor type will
 403    require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
 404
 405    This is represented internally as a RECORD_TYPE. The index nodes are
 406    gfc_array_index_type and the data node is a pointer to the data. See below
 407    for the handling of character types.
 408
 409    The dtype member is formatted as follows:
 410     rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
 411     type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
 412     size = dtype >> GFC_DTYPE_SIZE_SHIFT
 413
 414    I originally used nested ARRAY_TYPE nodes to represent arrays, but this
 415    generated poor code for assumed/deferred size arrays.  These require
 416    use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
 417    grammar.  Also, there is no way to explicitly set the array stride, so
 418    all data must be packed(1).  I've tried to mark all the functions which
 419    would require modification with a GCC ARRAYS comment.
 420
 421    The data component points to the first element in the array.
 422    The offset field is the position of the origin of the array
 423    (ie element (0, 0 ...)).  This may be outsite the bounds of the array.
 424
 425    An element is accessed by
 426    data[offset + index0*stride0 + index1*stride1 + index2*stride2]
 427    This gives good performance as the computation does not involve the
 428    bounds of the array.  For packed arrays, this is optimized further by
 429    substituting the known strides.
 430
 431    This system has one problem: all array bounds must be withing 2^31 elements
 432    of the origin (2^63 on 64-bit machines).  For example
 433    integer, dimension (80000:90000, 80000:90000, 2) :: array
 434    may not work properly on 32-bit machines because 80000*80000 > 2^31, so
 435    the calculation for stride02 would overflow.  This may still work, but
 436    I haven't checked, and it relies on the overflow doing the right thing.
 437
 438    The way to fix this problem is to access alements as follows:
 439    data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
 440    Obviously this is much slower.  I will make this a compile time option,
 441    something like -fsmall-array-offsets.  Mixing code compiled with and without
 442    this switch will work.
 443
 444    (1) This can be worked around by modifying the upper bound of the previous
 445    dimension.  This requires extra fields in the descriptor (both real_ubound
 446    and fake_ubound).  In tree.def there is mention of TYPE_SEP, which
 447    may allow us to do this.  However I can't find mention of this anywhere
 448    else.
 449  */
 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 actualy 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   component's backend_decl may have not been built.  */
1040   if (derived->backend_decl)
1041     {
1042       /* Its component's backend_decl has 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
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"