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>
6 This file is part of GCC.
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
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
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
23 /* trans-types.c -- gfortran backend types */
27 #include "coretypes.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
41 #if (GFC_MAX_DIMENSIONS < 10)
42 #define GFC_RANK_DIGITS 1
43 #define GFC_RANK_PRINTF_FORMAT "%01d"
44 #elif (GFC_MAX_DIMENSIONS < 100)
45 #define GFC_RANK_DIGITS 2
46 #define GFC_RANK_PRINTF_FORMAT "%02d"
48 #error If you really need >99 dimensions, continue the sequence above...
51 static tree gfc_get_derived_type (gfc_symbol * derived);
53 tree gfc_type_nodes[NUM_F95_TYPES];
55 tree gfc_array_index_type;
57 tree ppvoid_type_node;
60 static GTY(()) tree gfc_desc_dim_type = NULL;
62 static GTY(()) tree gfc_max_array_element_size;
64 /* Arrays for all integral and real kinds. We'll fill this in at runtime
65 after the target has a chance to process command-line options. */
67 #define MAX_INT_KINDS 5
68 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
69 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
71 #define MAX_REAL_KINDS 4
72 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
74 /* The integer kind to use for array indices. This will be set to the
75 proper value based on target information from the backend. */
77 int gfc_index_integer_kind;
79 /* The default kinds of the various types. */
81 static int gfc_default_integer_kind_1;
82 static int gfc_default_real_kind_1;
83 static int gfc_default_double_kind_1;
84 static int gfc_default_character_kind_1;
85 static int gfc_default_logical_kind_1;
86 static int gfc_default_complex_kind_1;
88 /* Query the target to determine which machine modes are available for
89 computation. Choose KIND numbers for them. */
94 enum machine_mode mode;
96 bool saw_i4 = false, saw_i8 = false;
97 bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
99 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
103 if (!targetm.scalar_mode_supported_p (mode))
106 if (i_index == MAX_INT_KINDS)
109 /* Let the kind equal the bit size divided by 8. This insulates the
110 programmer from the underlying byte size. */
111 bitsize = GET_MODE_BITSIZE (mode);
119 gfc_integer_kinds[i_index].kind = kind;
120 gfc_integer_kinds[i_index].radix = 2;
121 gfc_integer_kinds[i_index].digits = bitsize - 1;
122 gfc_integer_kinds[i_index].bit_size = bitsize;
124 gfc_logical_kinds[i_index].kind = kind;
125 gfc_logical_kinds[i_index].bit_size = bitsize;
130 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
132 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
137 if (!targetm.scalar_mode_supported_p (mode))
140 /* Let the kind equal the precision divided by 8, rounding up. Again,
141 this insulates the programmer from the underlying byte size.
143 Also, it effectively deals with IEEE extended formats. There, the
144 total size of the type may equal 16, but it's got 6 bytes of padding
145 and the increased size can get in the way of a real IEEE quad format
146 which may also be supported by the target.
148 We round up so as to handle IA-64 __floatreg (RFmode), which is an
149 82 bit type. Not to be confused with __float80 (XFmode), which is
150 an 80 bit type also supported by IA-64. So XFmode should come out
151 to be kind=10, and RFmode should come out to be kind=11. Egads. */
153 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
162 /* Careful we don't stumble a wierd internal mode. */
163 if (r_index > 0 && gfc_real_kinds[r_index-1].kind == kind)
165 /* Or have too many modes for the allocated space. */
166 if (r_index == MAX_REAL_KINDS)
169 gfc_real_kinds[r_index].kind = kind;
170 gfc_real_kinds[r_index].radix = fmt->b;
171 gfc_real_kinds[r_index].digits = fmt->p;
172 gfc_real_kinds[r_index].min_exponent = fmt->emin;
173 gfc_real_kinds[r_index].max_exponent = fmt->emax;
177 /* Choose the default integer kind. We choose 4 unless the user
178 directs us otherwise. */
182 fatal_error ("integer kind=8 not available for -i8 option");
183 gfc_default_integer_kind_1 = 8;
186 gfc_default_integer_kind_1 = 4;
188 gfc_default_integer_kind_1 = gfc_integer_kinds[i_index - 1].kind;
190 /* Choose the default real kind. Again, we choose 4 when possible. */
194 fatal_error ("real kind=8 not available for -r8 option");
195 gfc_default_real_kind_1 = 8;
198 gfc_default_real_kind_1 = 4;
200 gfc_default_real_kind_1 = gfc_real_kinds[0].kind;
202 /* Choose the default double kind. If -r8 is specified, we use kind=16,
203 if it's available, otherwise we do not change anything. */
204 if (gfc_option.r8 && saw_r16)
205 gfc_default_double_kind_1 = 16;
206 else if (saw_r4 && saw_r8)
207 gfc_default_double_kind_1 = 8;
210 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
211 real ... occupies two contiguous numeric storage units.
213 Therefore we must be supplied a kind twice as large as we chose
214 for single precision. There are loopholes, in that double
215 precision must *occupy* two storage units, though it doesn't have
216 to *use* two storage units. Which means that you can make this
217 kind artificially wide by padding it. But at present there are
218 no GCC targets for which a two-word type does not exist, so we
219 just let gfc_validate_kind abort and tell us if something breaks. */
221 gfc_default_double_kind_1
222 = gfc_validate_kind (BT_REAL, gfc_default_real_kind_1 * 2, false);
225 /* The default logical kind is constrained to be the same as the
226 default integer kind. Similarly with complex and real. */
227 gfc_default_logical_kind_1 = gfc_default_integer_kind_1;
228 gfc_default_complex_kind_1 = gfc_default_real_kind_1;
230 /* Choose the smallest integer kind for our default character. */
231 gfc_default_character_kind_1 = gfc_integer_kinds[0].kind;
233 /* Choose the integer kind the same size as "void*" for our index kind. */
234 gfc_index_integer_kind = POINTER_SIZE / 8;
237 /* ??? These functions should go away in favor of direct access to
238 the relevant variables. */
241 gfc_default_integer_kind (void)
243 return gfc_default_integer_kind_1;
247 gfc_default_real_kind (void)
249 return gfc_default_real_kind_1;
253 gfc_default_double_kind (void)
255 return gfc_default_double_kind_1;
259 gfc_default_character_kind (void)
261 return gfc_default_character_kind_1;
265 gfc_default_logical_kind (void)
267 return gfc_default_logical_kind_1;
271 gfc_default_complex_kind (void)
273 return gfc_default_complex_kind_1;
276 /* Make sure that a valid kind is present. Returns an index into the
277 associated kinds array, -1 if the kind is not present. */
280 validate_integer (int kind)
284 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
285 if (gfc_integer_kinds[i].kind == kind)
292 validate_real (int kind)
296 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
297 if (gfc_real_kinds[i].kind == kind)
304 validate_logical (int kind)
308 for (i = 0; gfc_logical_kinds[i].kind; i++)
309 if (gfc_logical_kinds[i].kind == kind)
316 validate_character (int kind)
318 return kind == gfc_default_character_kind_1 ? 0 : -1;
321 /* Validate a kind given a basic type. The return value is the same
322 for the child functions, with -1 indicating nonexistence of the
323 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
326 gfc_validate_kind (bt type, int kind, bool may_fail)
332 case BT_REAL: /* Fall through */
334 rc = validate_real (kind);
337 rc = validate_integer (kind);
340 rc = validate_logical (kind);
343 rc = validate_character (kind);
347 gfc_internal_error ("gfc_validate_kind(): Got bad type");
350 if (rc < 0 && !may_fail)
351 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
357 /* Create the backend type nodes. We map them to their
358 equivalent C type, at least for now. We also give
359 names to the types here, and we push them in the
360 global binding level context.*/
363 gfc_init_types (void)
366 unsigned HOST_WIDE_INT hi;
367 unsigned HOST_WIDE_INT lo;
369 /* Name the types. */
370 #define PUSH_TYPE(name, node) \
371 pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
373 gfc_int1_type_node = signed_char_type_node;
374 PUSH_TYPE ("int1", gfc_int1_type_node);
375 gfc_int2_type_node = short_integer_type_node;
376 PUSH_TYPE ("int2", gfc_int2_type_node);
377 gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ );
378 PUSH_TYPE ("int4", gfc_int4_type_node);
379 gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ );
380 PUSH_TYPE ("int8", gfc_int8_type_node);
381 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
382 gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ );
383 PUSH_TYPE ("int16", gfc_int16_type_node);
386 gfc_real4_type_node = float_type_node;
387 PUSH_TYPE ("real4", gfc_real4_type_node);
388 gfc_real8_type_node = double_type_node;
389 PUSH_TYPE ("real8", gfc_real8_type_node);
390 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
391 /* Hmm, this will not work. Ref. g77 */
392 gfc_real16_type_node = long_double_type_node;
393 PUSH_TYPE ("real16", gfc_real16_type_node);
396 gfc_complex4_type_node = complex_float_type_node;
397 PUSH_TYPE ("complex4", gfc_complex4_type_node);
398 gfc_complex8_type_node = complex_double_type_node;
399 PUSH_TYPE ("complex8", gfc_complex8_type_node);
400 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
401 /* Hmm, this will not work. Ref. g77 */
402 gfc_complex16_type_node = complex_long_double_type_node;
403 PUSH_TYPE ("complex16", gfc_complex16_type_node);
406 gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
407 TYPE_PRECISION (gfc_logical1_type_node) = 8;
408 fixup_unsigned_type (gfc_logical1_type_node);
409 PUSH_TYPE ("logical1", gfc_logical1_type_node);
410 gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
411 TYPE_PRECISION (gfc_logical2_type_node) = 16;
412 fixup_unsigned_type (gfc_logical2_type_node);
413 PUSH_TYPE ("logical2", gfc_logical2_type_node);
414 gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
415 TYPE_PRECISION (gfc_logical4_type_node) = 32;
416 fixup_unsigned_type (gfc_logical4_type_node);
417 PUSH_TYPE ("logical4", gfc_logical4_type_node);
418 gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
419 TYPE_PRECISION (gfc_logical8_type_node) = 64;
420 fixup_unsigned_type (gfc_logical8_type_node);
421 PUSH_TYPE ("logical8", gfc_logical8_type_node);
422 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
423 gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
424 TYPE_PRECISION (gfc_logical16_type_node) = 128;
425 fixup_unsigned_type (gfc_logical16_type_node);
426 PUSH_TYPE ("logical16", gfc_logical16_type_node);
429 gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
430 PUSH_TYPE ("char", gfc_character1_type_node);
432 PUSH_TYPE ("byte", unsigned_char_type_node);
433 PUSH_TYPE ("void", void_type_node);
435 /* DBX debugging output gets upset if these aren't set. */
436 if (!TYPE_NAME (integer_type_node))
437 PUSH_TYPE ("c_integer", integer_type_node);
438 if (!TYPE_NAME (char_type_node))
439 PUSH_TYPE ("c_char", char_type_node);
442 pvoid_type_node = build_pointer_type (void_type_node);
443 ppvoid_type_node = build_pointer_type (pvoid_type_node);
444 pchar_type_node = build_pointer_type (gfc_character1_type_node);
446 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
448 /* The maximum array element size that can be handled is determined
449 by the number of bits available to store this field in the array
452 n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type))
453 - GFC_DTYPE_SIZE_SHIFT;
455 if (n > sizeof (HOST_WIDE_INT) * 8)
457 lo = ~(unsigned HOST_WIDE_INT) 0;
458 hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n);
463 lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n);
465 gfc_max_array_element_size
466 = build_int_cst_wide (long_unsigned_type_node, lo, hi);
468 size_type_node = gfc_array_index_type;
469 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ());
471 boolean_true_node = build_int_cst (boolean_type_node, 1);
472 boolean_false_node = build_int_cst (boolean_type_node, 0);
475 /* Get a type node for an integer kind. */
478 gfc_get_int_type (int kind)
483 return (gfc_int1_type_node);
485 return (gfc_int2_type_node);
487 return (gfc_int4_type_node);
489 return (gfc_int8_type_node);
490 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
492 return (95 _int16_type_node);
495 fatal_error ("integer kind=%d not available", kind);
499 /* Get a type node for a real kind. */
502 gfc_get_real_type (int kind)
507 return (gfc_real4_type_node);
509 return (gfc_real8_type_node);
510 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
512 return (gfc_real16_type_node);
515 fatal_error ("real kind=%d not available", kind);
519 /* Get a type node for a complex kind. */
522 gfc_get_complex_type (int kind)
528 return (gfc_complex4_type_node);
530 return (gfc_complex8_type_node);
531 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
533 return (gfc_complex16_type_node);
536 fatal_error ("complex kind=%d not available", kind);
540 /* Get a type node for a logical kind. */
543 gfc_get_logical_type (int kind)
548 return (gfc_logical1_type_node);
550 return (gfc_logical2_type_node);
552 return (gfc_logical4_type_node);
554 return (gfc_logical8_type_node);
555 #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
557 return (gfc_logical16_type_node);
560 fatal_error ("logical kind=%d not available", kind);
564 /* Create a character type with the given kind and length. */
567 gfc_get_character_type_len (int kind, tree len)
576 base = gfc_character1_type_node;
580 fatal_error ("character kind=%d not available", kind);
583 bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
584 type = build_array_type (base, bounds);
585 TYPE_STRING_FLAG (type) = 1;
591 /* Get a type node for a character kind. */
594 gfc_get_character_type (int kind, gfc_charlen * cl)
598 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
600 return gfc_get_character_type_len (kind, len);
603 /* Covert a basic type. This will be an array for character types. */
606 gfc_typenode_for_spec (gfc_typespec * spec)
617 basetype = gfc_get_int_type (spec->kind);
621 basetype = gfc_get_real_type (spec->kind);
625 basetype = gfc_get_complex_type (spec->kind);
629 basetype = gfc_get_logical_type (spec->kind);
633 basetype = gfc_get_character_type (spec->kind, spec->cl);
637 basetype = gfc_get_derived_type (spec->derived);
647 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
650 gfc_conv_array_bound (gfc_expr * expr)
652 /* If expr is an integer constant, return that. */
653 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
654 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
656 /* Otherwise return NULL. */
661 gfc_get_element_type (tree type)
665 if (GFC_ARRAY_TYPE_P (type))
667 if (TREE_CODE (type) == POINTER_TYPE)
668 type = TREE_TYPE (type);
669 assert (TREE_CODE (type) == ARRAY_TYPE);
670 element = TREE_TYPE (type);
674 assert (GFC_DESCRIPTOR_TYPE_P (type));
675 element = TREE_TYPE (TYPE_FIELDS (type));
677 assert (TREE_CODE (element) == POINTER_TYPE);
678 element = TREE_TYPE (element);
680 assert (TREE_CODE (element) == ARRAY_TYPE);
681 element = TREE_TYPE (element);
687 /* Build an array. This function is called from gfc_sym_type().
688 Actually returns array descriptor type.
690 Format of array descriptors is as follows:
692 struct gfc_array_descriptor
697 struct descriptor_dimension dimension[N_DIM];
700 struct descriptor_dimension
707 Translation code should use gfc_conv_descriptor_* rather than accessing
708 the descriptor directly. Any changes to the array descriptor type will
709 require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
711 This is represented internally as a RECORD_TYPE. The index nodes are
712 gfc_array_index_type and the data node is a pointer to the data. See below
713 for the handling of character types.
715 The dtype member is formatted as follows:
716 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
717 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
718 size = dtype >> GFC_DTYPE_SIZE_SHIFT
720 I originally used nested ARRAY_TYPE nodes to represent arrays, but this
721 generated poor code for assumed/deferred size arrays. These require
722 use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
723 grammar. Also, there is no way to explicitly set the array stride, so
724 all data must be packed(1). I've tried to mark all the functions which
725 would require modification with a GCC ARRAYS comment.
727 The data component points to the first element in the array.
728 The offset field is the position of the origin of the array
729 (ie element (0, 0 ...)). This may be outsite the bounds of the array.
731 An element is accessed by
732 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
733 This gives good performance as the computation does not involve the
734 bounds of the array. For packed arrays, this is optimized further by
735 substituting the known strides.
737 This system has one problem: all array bounds must be withing 2^31 elements
738 of the origin (2^63 on 64-bit machines). For example
739 integer, dimension (80000:90000, 80000:90000, 2) :: array
740 may not work properly on 32-bit machines because 80000*80000 > 2^31, so
741 the calculation for stride02 would overflow. This may still work, but
742 I haven't checked, and it relies on the overflow doing the right thing.
744 The way to fix this problem is to access alements as follows:
745 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
746 Obviously this is much slower. I will make this a compile time option,
747 something like -fsmall-array-offsets. Mixing code compiled with and without
748 this switch will work.
750 (1) This can be worked around by modifying the upper bound of the previous
751 dimension. This requires extra fields in the descriptor (both real_ubound
752 and fake_ubound). In tree.def there is mention of TYPE_SEP, which
753 may allow us to do this. However I can't find mention of this anywhere
757 /* Returns true if the array sym does not require a descriptor. */
760 gfc_is_nodesc_array (gfc_symbol * sym)
762 assert (sym->attr.dimension);
764 /* We only want local arrays. */
765 if (sym->attr.pointer || sym->attr.allocatable)
770 if (sym->as->type != AS_ASSUMED_SHAPE)
776 if (sym->attr.result || sym->attr.function)
779 if (sym->attr.pointer || sym->attr.allocatable)
782 assert (sym->as->type == AS_EXPLICIT);
788 /* Create an array descriptor type. */
791 gfc_build_array_type (tree type, gfc_array_spec * as)
793 tree lbound[GFC_MAX_DIMENSIONS];
794 tree ubound[GFC_MAX_DIMENSIONS];
797 for (n = 0; n < as->rank; n++)
799 /* Create expressions for the known bounds of the array. */
800 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
801 lbound[n] = gfc_index_one_node;
803 lbound[n] = gfc_conv_array_bound (as->lower[n]);
804 ubound[n] = gfc_conv_array_bound (as->upper[n]);
807 return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
810 /* Returns the struct descriptor_dimension type. */
813 gfc_get_desc_dim_type (void)
819 if (gfc_desc_dim_type)
820 return gfc_desc_dim_type;
822 /* Build the type node. */
823 type = make_node (RECORD_TYPE);
825 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
826 TYPE_PACKED (type) = 1;
828 /* Consists of the stride, lbound and ubound members. */
829 decl = build_decl (FIELD_DECL,
830 get_identifier ("stride"), gfc_array_index_type);
831 DECL_CONTEXT (decl) = type;
834 decl = build_decl (FIELD_DECL,
835 get_identifier ("lbound"), gfc_array_index_type);
836 DECL_CONTEXT (decl) = type;
837 fieldlist = chainon (fieldlist, decl);
839 decl = build_decl (FIELD_DECL,
840 get_identifier ("ubound"), gfc_array_index_type);
841 DECL_CONTEXT (decl) = type;
842 fieldlist = chainon (fieldlist, decl);
844 /* Finish off the type. */
845 TYPE_FIELDS (type) = fieldlist;
847 gfc_finish_type (type);
849 gfc_desc_dim_type = type;
854 gfc_get_dtype (tree type, int rank)
862 if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
863 return (GFC_TYPE_ARRAY_DTYPE (type));
865 /* TODO: Correctly identify LOGICAL types. */
866 switch (TREE_CODE (type))
869 n = GFC_DTYPE_INTEGER;
873 n = GFC_DTYPE_LOGICAL;
881 n = GFC_DTYPE_COMPLEX;
884 /* Arrays have already been dealt with. */
886 n = GFC_DTYPE_DERIVED;
890 n = GFC_DTYPE_CHARACTER;
894 /* TODO: Don't do dtype for temporary descriptorless arrays. */
895 /* We can strange array types for temporary arrays. */
896 return gfc_index_zero_node;
899 assert (rank <= GFC_DTYPE_RANK_MASK);
900 size = TYPE_SIZE_UNIT (type);
902 i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
903 if (size && INTEGER_CST_P (size))
905 if (tree_int_cst_lt (gfc_max_array_element_size, size))
906 internal_error ("Array element size too big");
908 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
910 dtype = build_int_cst (gfc_array_index_type, i);
912 if (size && !INTEGER_CST_P (size))
914 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
915 tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
916 dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
918 /* If we don't know the size we leave it as zero. This should never happen
919 for anything that is actually used. */
920 /* TODO: Check this is actually true, particularly when repacking
921 assumed size parameters. */
927 /* Build an array type for use without a descriptor. Valid values of packed
928 are 0=no, 1=partial, 2=full, 3=static. */
931 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
944 mpz_init_set_ui (offset, 0);
945 mpz_init_set_ui (stride, 1);
948 /* We don't use build_array_type because this does not include include
949 lang-specific information (ie. the bounds of the array) when checking
951 type = make_node (ARRAY_TYPE);
953 GFC_ARRAY_TYPE_P (type) = 1;
954 TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
955 ggc_alloc_cleared (sizeof (struct lang_type));
957 known_stride = (packed != 0);
959 for (n = 0; n < as->rank; n++)
961 /* Fill in the stride and bound components of the type. */
963 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
966 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
969 if (expr->expr_type == EXPR_CONSTANT)
971 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
972 gfc_index_integer_kind);
979 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
983 /* Calculate the offset. */
984 mpz_mul (delta, stride, as->lower[n]->value.integer);
985 mpz_sub (offset, offset, delta);
991 if (expr && expr->expr_type == EXPR_CONSTANT)
993 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
994 gfc_index_integer_kind);
1001 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1005 /* Calculate the stride. */
1006 mpz_sub (delta, as->upper[n]->value.integer,
1007 as->lower[n]->value.integer);
1008 mpz_add_ui (delta, delta, 1);
1009 mpz_mul (stride, stride, delta);
1012 /* Only the first stride is known for partial packed arrays. */
1019 GFC_TYPE_ARRAY_OFFSET (type) =
1020 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
1023 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
1027 GFC_TYPE_ARRAY_SIZE (type) =
1028 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1031 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
1033 GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
1034 GFC_TYPE_ARRAY_RANK (type) = as->rank;
1035 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1037 /* TODO: use main type if it is unbounded. */
1038 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
1039 build_pointer_type (build_array_type (etype, range));
1043 mpz_sub_ui (stride, stride, 1);
1044 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
1049 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
1050 TYPE_DOMAIN (type) = range;
1052 build_pointer_type (etype);
1053 TREE_TYPE (type) = etype;
1061 if (packed < 3 || !known_stride)
1063 /* For dummy arrays and automatic (heap allocated) arrays we
1064 want a pointer to the array. */
1065 type = build_pointer_type (type);
1066 GFC_ARRAY_TYPE_P (type) = 1;
1067 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
1073 /* Build an array (descriptor) type with given bounds. */
1076 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
1077 tree * ubound, int packed)
1079 tree fat_type, fat_pointer_type;
1084 char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
1085 const char *typename;
1091 /* Build the type node. */
1092 fat_type = make_node (RECORD_TYPE);
1093 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
1094 TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
1095 ggc_alloc_cleared (sizeof (struct lang_type));
1096 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
1097 GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
1099 tmp = TYPE_NAME (etype);
1100 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
1101 tmp = DECL_NAME (tmp);
1103 typename = IDENTIFIER_POINTER (tmp);
1105 typename = "unknown";
1107 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
1108 GFC_MAX_SYMBOL_LEN, typename);
1109 TYPE_NAME (fat_type) = get_identifier (name);
1110 TYPE_PACKED (fat_type) = 0;
1112 fat_pointer_type = build_pointer_type (fat_type);
1114 /* Build an array descriptor record type. */
1116 stride = gfc_index_one_node;
1120 for (n = 0; n < dimen; n++)
1122 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
1129 if (lower != NULL_TREE)
1131 if (INTEGER_CST_P (lower))
1132 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
1138 if (upper != NULL_TREE)
1140 if (INTEGER_CST_P (upper))
1141 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
1146 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
1148 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
1149 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
1150 gfc_index_one_node));
1152 fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
1153 /* Check the folding worked. */
1154 assert (INTEGER_CST_P (stride));
1159 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
1160 /* TODO: known offsets for descriptors. */
1161 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
1163 /* We define data as an unknown size array. Much better than doing
1164 pointer arithmetic. */
1166 build_array_type (etype,
1167 build_range_type (gfc_array_index_type,
1168 gfc_index_zero_node, NULL_TREE));
1169 arraytype = build_pointer_type (arraytype);
1170 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
1172 /* The pointer to the array data. */
1173 decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
1175 DECL_CONTEXT (decl) = fat_type;
1176 /* Add the data member as the first element of the descriptor. */
1179 /* Add the base component. */
1180 decl = build_decl (FIELD_DECL, get_identifier ("offset"),
1181 gfc_array_index_type);
1182 DECL_CONTEXT (decl) = fat_type;
1183 fieldlist = chainon (fieldlist, decl);
1185 /* Add the dtype component. */
1186 decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
1187 gfc_array_index_type);
1188 DECL_CONTEXT (decl) = fat_type;
1189 fieldlist = chainon (fieldlist, decl);
1191 /* Build the array type for the stride and bound components. */
1193 build_array_type (gfc_get_desc_dim_type (),
1194 build_range_type (gfc_array_index_type,
1195 gfc_index_zero_node,
1196 gfc_rank_cst[dimen - 1]));
1198 decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
1199 DECL_CONTEXT (decl) = fat_type;
1200 DECL_INITIAL (decl) = NULL_TREE;
1201 fieldlist = chainon (fieldlist, decl);
1203 /* Finish off the type. */
1204 TYPE_FIELDS (fat_type) = fieldlist;
1206 gfc_finish_type (fat_type);
1211 /* Build a pointer type. This function is called from gfc_sym_type(). */
1214 gfc_build_pointer_type (gfc_symbol * sym, tree type)
1216 /* Array pointer types aren't actually pointers. */
1217 if (sym->attr.dimension)
1220 return build_pointer_type (type);
1223 /* Return the type for a symbol. Special handling is required for character
1224 types to get the correct level of indirection.
1225 For functions return the return type.
1226 For subroutines return void_type_node.
1227 Calling this multiple times for the same symbol should be avoided,
1228 especially for character and array types. */
1231 gfc_sym_type (gfc_symbol * sym)
1236 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
1237 return void_type_node;
1239 if (sym->backend_decl)
1241 if (sym->attr.function)
1242 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
1244 return TREE_TYPE (sym->backend_decl);
1247 /* The frontend doesn't set all the attributes for a function with an
1248 explicit result value, so we use that instead when present. */
1249 if (sym->attr.function && sym->result)
1252 type = gfc_typenode_for_spec (&sym->ts);
1254 if (sym->attr.dummy && !sym->attr.function)
1259 if (sym->attr.dimension)
1261 if (gfc_is_nodesc_array (sym))
1263 /* If this is a character argument of unknown length, just use the
1265 if (sym->ts.type != BT_CHARACTER
1266 || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
1267 || sym->ts.cl->backend_decl)
1269 type = gfc_get_nodesc_array_type (type, sym->as,
1275 type = gfc_build_array_type (type, sym->as);
1279 if (sym->attr.allocatable || sym->attr.pointer)
1280 type = gfc_build_pointer_type (sym, type);
1283 /* We currently pass all parameters by reference.
1284 See f95_get_function_decl. For dummy function parameters return the
1288 /* We must use pointer types for potentially absent variables. The
1289 optimizers assume a reference type argument is never NULL. */
1290 if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1291 type = build_pointer_type (type);
1293 type = build_reference_type (type);
1299 /* Layout and output debug info for a record type. */
1302 gfc_finish_type (tree type)
1306 decl = build_decl (TYPE_DECL, NULL_TREE, type);
1307 TYPE_STUB_DECL (type) = decl;
1309 rest_of_type_compilation (type, 1);
1310 rest_of_decl_compilation (decl, 1, 0);
1313 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1314 or RECORD_TYPE pointed to by STYPE. The new field is chained
1315 to the fieldlist pointed to by FIELDLIST.
1317 Returns a pointer to the new field. */
1320 gfc_add_field_to_struct (tree *fieldlist, tree context,
1321 tree name, tree type)
1325 decl = build_decl (FIELD_DECL, name, type);
1327 DECL_CONTEXT (decl) = context;
1328 DECL_INITIAL (decl) = 0;
1329 DECL_ALIGN (decl) = 0;
1330 DECL_USER_ALIGN (decl) = 0;
1331 TREE_CHAIN (decl) = NULL_TREE;
1332 *fieldlist = chainon (*fieldlist, decl);
1338 /* Build a tree node for a derived type. */
1341 gfc_get_derived_type (gfc_symbol * derived)
1343 tree typenode, field, field_type, fieldlist;
1346 assert (derived && derived->attr.flavor == FL_DERIVED);
1348 /* derived->backend_decl != 0 means we saw it before, but its
1349 components' backend_decl may have not been built. */
1350 if (derived->backend_decl)
1352 /* Its components' backend_decl have been built. */
1353 if (TYPE_FIELDS (derived->backend_decl))
1354 return derived->backend_decl;
1356 typenode = derived->backend_decl;
1360 /* We see this derived type first time, so build the type node. */
1361 typenode = make_node (RECORD_TYPE);
1362 TYPE_NAME (typenode) = get_identifier (derived->name);
1363 TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
1364 derived->backend_decl = typenode;
1367 /* Build the type member list. Install the newly created RECORD_TYPE
1368 node as DECL_CONTEXT of each FIELD_DECL. */
1369 fieldlist = NULL_TREE;
1370 for (c = derived->components; c; c = c->next)
1372 if (c->ts.type == BT_DERIVED && c->pointer)
1374 if (c->ts.derived->backend_decl)
1375 field_type = c->ts.derived->backend_decl;
1378 /* Build the type node. */
1379 field_type = make_node (RECORD_TYPE);
1380 TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
1381 TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
1382 c->ts.derived->backend_decl = field_type;
1387 if (c->ts.type == BT_CHARACTER)
1389 /* Evaluate the string length. */
1390 gfc_conv_const_charlen (c->ts.cl);
1391 assert (c->ts.cl->backend_decl);
1394 field_type = gfc_typenode_for_spec (&c->ts);
1397 /* This returns an array descriptor type. Initialisation may be
1403 /* Pointers to arrays aren't actualy pointer types. The
1404 descriptors are seperate, but the data is common. */
1405 field_type = gfc_build_array_type (field_type, c->as);
1408 field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
1410 else if (c->pointer)
1411 field_type = build_pointer_type (field_type);
1413 field = gfc_add_field_to_struct (&fieldlist, typenode,
1414 get_identifier (c->name),
1417 DECL_PACKED (field) |= TYPE_PACKED (typenode);
1419 assert (!c->backend_decl);
1420 c->backend_decl = field;
1423 /* Now we have the final fieldlist. Record it, then lay out the
1424 derived type, including the fields. */
1425 TYPE_FIELDS (typenode) = fieldlist;
1427 gfc_finish_type (typenode);
1429 derived->backend_decl = typenode;
1435 gfc_return_by_reference (gfc_symbol * sym)
1437 if (!sym->attr.function)
1440 assert (sym->attr.function);
1445 if (sym->attr.dimension)
1448 if (sym->ts.type == BT_CHARACTER)
1451 if (sym->ts.type == BT_DERIVED)
1452 gfc_todo_error ("Returning derived types");
1453 /* Possibly return derived types by reference. */
1458 gfc_get_function_type (gfc_symbol * sym)
1462 gfc_formal_arglist *f;
1465 int alternate_return;
1467 /* Make sure this symbol is a function or a subroutine. */
1468 assert (sym->attr.flavor == FL_PROCEDURE);
1470 if (sym->backend_decl)
1471 return TREE_TYPE (sym->backend_decl);
1474 alternate_return = 0;
1475 typelist = NULL_TREE;
1477 if (sym->attr.entry_master)
1479 /* Additional parameter for selecting an entry point. */
1480 typelist = gfc_chainon_list (typelist, gfc_array_index_type);
1483 /* Some functions we use an extra parameter for the return value. */
1484 if (gfc_return_by_reference (sym))
1491 if (arg->ts.type == BT_CHARACTER)
1492 gfc_conv_const_charlen (arg->ts.cl);
1494 type = gfc_sym_type (arg);
1495 if (arg->ts.type == BT_DERIVED
1496 || arg->attr.dimension
1497 || arg->ts.type == BT_CHARACTER)
1498 type = build_reference_type (type);
1500 typelist = gfc_chainon_list (typelist, type);
1501 if (arg->ts.type == BT_CHARACTER)
1502 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1505 /* Build the argument types for the function. */
1506 for (f = sym->formal; f; f = f->next)
1511 /* Evaluate constant character lengths here so that they can be
1512 included in the type. */
1513 if (arg->ts.type == BT_CHARACTER)
1514 gfc_conv_const_charlen (arg->ts.cl);
1516 if (arg->attr.flavor == FL_PROCEDURE)
1518 type = gfc_get_function_type (arg);
1519 type = build_pointer_type (type);
1522 type = gfc_sym_type (arg);
1524 /* Parameter Passing Convention
1526 We currently pass all parameters by reference.
1527 Parameters with INTENT(IN) could be passed by value.
1528 The problem arises if a function is called via an implicit
1529 prototype. In this situation the INTENT is not known.
1530 For this reason all parameters to global functions must be
1531 passed by reference. Passing by value would potentialy
1532 generate bad code. Worse there would be no way of telling that
1533 this code was bad, except that it would give incorrect results.
1535 Contained procedures could pass by value as these are never
1536 used without an explicit interface, and connot be passed as
1537 actual parameters for a dummy procedure. */
1538 if (arg->ts.type == BT_CHARACTER)
1540 typelist = gfc_chainon_list (typelist, type);
1544 if (sym->attr.subroutine)
1545 alternate_return = 1;
1549 /* Add hidden string length parameters. */
1551 typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
1553 typelist = gfc_chainon_list (typelist, void_type_node);
1555 if (alternate_return)
1556 type = integer_type_node;
1557 else if (!sym->attr.function || gfc_return_by_reference (sym))
1558 type = void_type_node;
1560 type = gfc_sym_type (sym);
1562 type = build_function_type (type, typelist);
1567 /* Routines for getting integer type nodes. */
1570 /* Return an integer type with BITS bits of precision,
1571 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
1574 gfc_type_for_size (unsigned bits, int unsignedp)
1576 if (bits == TYPE_PRECISION (integer_type_node))
1577 return unsignedp ? unsigned_type_node : integer_type_node;
1579 if (bits == TYPE_PRECISION (signed_char_type_node))
1580 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1582 if (bits == TYPE_PRECISION (short_integer_type_node))
1583 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1585 if (bits == TYPE_PRECISION (long_integer_type_node))
1586 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1588 if (bits == TYPE_PRECISION (long_long_integer_type_node))
1589 return (unsignedp ? long_long_unsigned_type_node
1590 : long_long_integer_type_node);
1591 /*TODO: We currently don't initialise this...
1592 if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
1593 return (unsignedp ? widest_unsigned_literal_type_node
1594 : widest_integer_literal_type_node);*/
1596 if (bits <= TYPE_PRECISION (intQI_type_node))
1597 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1599 if (bits <= TYPE_PRECISION (intHI_type_node))
1600 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1602 if (bits <= TYPE_PRECISION (intSI_type_node))
1603 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1605 if (bits <= TYPE_PRECISION (intDI_type_node))
1606 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1611 /* Return a data type that has machine mode MODE.
1612 If the mode is an integer,
1613 then UNSIGNEDP selects between signed and unsigned types. */
1616 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
1618 if (mode == TYPE_MODE (integer_type_node))
1619 return unsignedp ? unsigned_type_node : integer_type_node;
1621 if (mode == TYPE_MODE (signed_char_type_node))
1622 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1624 if (mode == TYPE_MODE (short_integer_type_node))
1625 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1627 if (mode == TYPE_MODE (long_integer_type_node))
1628 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1630 if (mode == TYPE_MODE (long_long_integer_type_node))
1631 return unsignedp ? long_long_unsigned_type_node :
1632 long_long_integer_type_node;
1635 if (mode == TYPE_MODE (widest_integer_literal_type_node))
1636 return unsignedp ? widest_unsigned_literal_type_node
1637 : widest_integer_literal_type_node;
1641 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1644 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1647 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1650 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1652 #if HOST_BITS_PER_WIDE_INT >= 64
1653 if (mode == TYPE_MODE (intTI_type_node))
1654 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1657 if (mode == TYPE_MODE (float_type_node))
1658 return float_type_node;
1660 if (mode == TYPE_MODE (double_type_node))
1661 return double_type_node;
1663 if (mode == TYPE_MODE (long_double_type_node))
1664 return long_double_type_node;
1666 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
1667 return build_pointer_type (char_type_node);
1669 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
1670 return build_pointer_type (integer_type_node);
1672 if (VECTOR_MODE_P (mode))
1674 enum machine_mode inner_mode = GET_MODE_INNER (mode);
1675 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
1676 if (inner_type != NULL_TREE)
1677 return build_vector_type_for_mode (inner_type, mode);
1683 /* Return an unsigned type the same as TYPE in other respects. */
1686 gfc_unsigned_type (tree type)
1688 tree type1 = TYPE_MAIN_VARIANT (type);
1690 if (type1 == signed_char_type_node || type1 == char_type_node)
1691 return unsigned_char_type_node;
1692 if (type1 == integer_type_node)
1693 return unsigned_type_node;
1694 if (type1 == short_integer_type_node)
1695 return short_unsigned_type_node;
1696 if (type1 == long_integer_type_node)
1697 return long_unsigned_type_node;
1698 if (type1 == long_long_integer_type_node)
1699 return long_long_unsigned_type_node;
1701 if (type1 == widest_integer_literal_type_node)
1702 return widest_unsigned_literal_type_node;
1704 #if HOST_BITS_PER_WIDE_INT >= 64
1705 if (type1 == intTI_type_node)
1706 return unsigned_intTI_type_node;
1708 if (type1 == intDI_type_node)
1709 return unsigned_intDI_type_node;
1710 if (type1 == intSI_type_node)
1711 return unsigned_intSI_type_node;
1712 if (type1 == intHI_type_node)
1713 return unsigned_intHI_type_node;
1714 if (type1 == intQI_type_node)
1715 return unsigned_intQI_type_node;
1717 return gfc_signed_or_unsigned_type (1, type);
1720 /* Return a signed type the same as TYPE in other respects. */
1723 gfc_signed_type (tree type)
1725 tree type1 = TYPE_MAIN_VARIANT (type);
1727 if (type1 == unsigned_char_type_node || type1 == char_type_node)
1728 return signed_char_type_node;
1729 if (type1 == unsigned_type_node)
1730 return integer_type_node;
1731 if (type1 == short_unsigned_type_node)
1732 return short_integer_type_node;
1733 if (type1 == long_unsigned_type_node)
1734 return long_integer_type_node;
1735 if (type1 == long_long_unsigned_type_node)
1736 return long_long_integer_type_node;
1738 if (type1 == widest_unsigned_literal_type_node)
1739 return widest_integer_literal_type_node;
1741 #if HOST_BITS_PER_WIDE_INT >= 64
1742 if (type1 == unsigned_intTI_type_node)
1743 return intTI_type_node;
1745 if (type1 == unsigned_intDI_type_node)
1746 return intDI_type_node;
1747 if (type1 == unsigned_intSI_type_node)
1748 return intSI_type_node;
1749 if (type1 == unsigned_intHI_type_node)
1750 return intHI_type_node;
1751 if (type1 == unsigned_intQI_type_node)
1752 return intQI_type_node;
1754 return gfc_signed_or_unsigned_type (0, type);
1757 /* Return a type the same as TYPE except unsigned or
1758 signed according to UNSIGNEDP. */
1761 gfc_signed_or_unsigned_type (int unsignedp, tree type)
1763 if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
1766 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
1767 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
1768 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
1769 return unsignedp ? unsigned_type_node : integer_type_node;
1770 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
1771 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
1772 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
1773 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
1774 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
1775 return (unsignedp ? long_long_unsigned_type_node
1776 : long_long_integer_type_node);
1778 if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
1779 return (unsignedp ? widest_unsigned_literal_type_node
1780 : widest_integer_literal_type_node);
1782 #if HOST_BITS_PER_WIDE_INT >= 64
1783 if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
1784 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
1786 if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
1787 return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
1788 if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
1789 return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
1790 if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
1791 return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
1792 if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
1793 return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
1798 #include "gt-fortran-trans-types.h"