tree
gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
{
int i;
tree str, len;
size_t size;
char *s;
i = gfc_validate_kind (BT_CHARACTER, kind, false);
size = length * gfc_character_kinds[i].bit_size / 8;
s = XCNEWVAR (char, size);
gfc_encode_character (kind, length, string, (unsigned char *) s, size);
str = build_string (size, s);
free (s);
len = size_int (length);
TREE_TYPE (str) =
build_array_type (gfc_get_char_type (kind),
build_range_type (gfc_charlen_type_node,
size_one_node, len));
TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
return str;
}
tree
gfc_build_inf_or_huge (tree type, int kind)
{
if (HONOR_INFINITIES (TYPE_MODE (type)))
{
REAL_VALUE_TYPE real;
real_inf (&real);
return build_real (type, real);
}
else
{
int k = gfc_validate_kind (BT_REAL, kind, false);
return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
}
}
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
{
tree type;
int n;
REAL_VALUE_TYPE real;
n = gfc_validate_kind (BT_REAL, kind, false);
gcc_assert (gfc_real_kinds[n].radix == 2);
type = gfc_get_real_type (kind);
if (mpfr_nan_p (f) && is_snan)
real_from_string (&real, "SNaN");
else
real_from_mpfr (&real, f, type, GFC_RND_MODE);
return build_real (type, real);
}
static size_t
size_character (int length, int kind)
{
int i = gfc_validate_kind (BT_CHARACTER, kind, false);
return length * gfc_character_kinds[i].bit_size / 8;
}
void
gfc_init_kinds (void)
{
enum machine_mode mode;
int i_index, r_index;
bool saw_i4 = false, saw_i8 = false;
bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
{
int kind, bitsize;
if (!targetm.scalar_mode_supported_p (mode))
continue;
/* The middle end doesn't support constants larger than 2*HWI.
Perhaps the target hook shouldn't have accepted these either,
but just to be safe... */
bitsize = GET_MODE_BITSIZE (mode);
if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
continue;
gcc_assert (i_index != MAX_INT_KINDS);
/* Let the kind equal the bit size divided by 8. This insulates the
programmer from the underlying byte size. */
kind = bitsize / 8;
if (kind == 4)
saw_i4 = true;
if (kind == 8)
saw_i8 = true;
gfc_integer_kinds[i_index].kind = kind;
gfc_integer_kinds[i_index].radix = 2;
gfc_integer_kinds[i_index].digits = bitsize - 1;
gfc_integer_kinds[i_index].bit_size = bitsize;
gfc_logical_kinds[i_index].kind = kind;
gfc_logical_kinds[i_index].bit_size = bitsize;
i_index += 1;
}
/* Set the maximum integer kind. Used with at least BOZ constants. */
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
int kind;
if (fmt == NULL)
continue;
if (!targetm.scalar_mode_supported_p (mode))
continue;
/* Let the kind equal the precision divided by 8, rounding up. Again,
this insulates the programmer from the underlying byte size.
Also, it effectively deals with IEEE extended formats. There, the
total size of the type may equal 16, but it's got 6 bytes of padding
and the increased size can get in the way of a real IEEE quad format
which may also be supported by the target.
We round up so as to handle IA-64 __floatreg (RFmode), which is an
82 bit type. Not to be confused with __float80 (XFmode), which is
an 80 bit type also supported by IA-64. So XFmode should come out
to be kind=10, and RFmode should come out to be kind=11. Egads. */
kind = (GET_MODE_PRECISION (mode) + 7) / 8;
if (kind == 4)
saw_r4 = true;
if (kind == 8)
saw_r8 = true;
if (kind == 16)
saw_r16 = true;
/* Careful we don't stumble a wierd internal mode. */
gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
/* Or have too many modes for the allocated space. */
gcc_assert (r_index != MAX_REAL_KINDS);
gfc_real_kinds[r_index].kind = kind;
gfc_real_kinds[r_index].radix = fmt->b;
gfc_real_kinds[r_index].digits = fmt->p;
gfc_real_kinds[r_index].min_exponent = fmt->emin;
gfc_real_kinds[r_index].max_exponent = fmt->emax;
gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
r_index += 1;
}
/* Choose the default integer kind. We choose 4 unless the user
directs us otherwise. */
if (gfc_option.flag_default_integer)
{
if (!saw_i8)
fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
gfc_default_integer_kind = 8;
}
else if (saw_i4)
gfc_default_integer_kind = 4;
else
gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
/* Choose the default real kind. Again, we choose 4 when possible. */
if (gfc_option.flag_default_real)
{
if (!saw_r8)
fatal_error ("real kind=8 not available for -fdefault-real-8 option");
gfc_default_real_kind = 8;
}
else if (saw_r4)
gfc_default_real_kind = 4;
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
/* Choose the default double kind. If -fdefault-real and -fdefault-double
are specified, we use kind=8, if it's available. If -fdefault-real is
specified without -fdefault-double, we use kind=16, if it's available.
Otherwise we do not change anything. */
if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
gfc_default_double_kind = 8;
else if (gfc_option.flag_default_real && saw_r16)
gfc_default_double_kind = 16;
else if (saw_r4 && saw_r8)
gfc_default_double_kind = 8;
else
{
/* F95 14.6.3.1: A nonpointer scalar object of type double precision
real ... occupies two contiguous numeric storage units.
Therefore we must be supplied a kind twice as large as we chose
for single precision. There are loopholes, in that double
precision must *occupy* two storage units, though it doesn't have
to *use* two storage units. Which means that you can make this
kind artificially wide by padding it. But at present there are
no GCC targets for which a two-word type does not exist, so we
just let gfc_validate_kind abort and tell us if something breaks. */
gfc_default_double_kind
= gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
}
/* The default logical kind is constrained to be the same as the
default integer kind. Similarly with complex and real. */
gfc_default_logical_kind = gfc_default_integer_kind;
gfc_default_complex_kind = gfc_default_real_kind;
/* Choose the smallest integer kind for our default character. */
gfc_default_character_kind = gfc_integer_kinds[0].kind;
/* Choose the integer kind the same size as "void*" for our index kind. */
gfc_index_integer_kind = POINTER_SIZE / 8;
/* Pick a kind the same size as the C "int" type. */
gfc_c_int_kind = INT_TYPE_SIZE / 8;
}
