Commit efaa05d8 by Steven G. Kargl

re PR fortran/88227 (ICE in gfc_convert_boz, at fortran/target-memory.c:788)

2019-08-04  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/88227
	* check.c (oct2bin):  New function.  Convert octal string to binary.
	(hex2bin): New function.  Convert hexidecimal string to binary.
	(bin2real): New function.  Convert binary string to REAL.  Use
	oct2bin and hex2bin.
	(gfc_boz2real):  Use fallback conversion bin2real.

From-SVN: r274096
parent 011fc8c6
2019-08-04 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/88227
* check.c (oct2bin): New function. Convert octal string to binary.
(hex2bin): New function. Convert hexidecimal string to binary.
(bin2real): New function. Convert binary string to REAL. Use
oct2bin and hex2bin.
(gfc_boz2real): Use fallback conversion bin2real.
2019-08-02 Steven G. Kargl <kargl@gcc.gnu.org> 2019-08-02 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/90985 PR fortran/90985
......
...@@ -55,6 +55,7 @@ gfc_invalid_boz (const char *msg, locus *loc) ...@@ -55,6 +55,7 @@ gfc_invalid_boz (const char *msg, locus *loc)
/* Issue an error for an illegal BOZ argument. */ /* Issue an error for an illegal BOZ argument. */
static bool static bool
illegal_boz_arg (gfc_expr *x) illegal_boz_arg (gfc_expr *x)
{ {
...@@ -101,6 +102,167 @@ is_boz_constant (gfc_expr *a) ...@@ -101,6 +102,167 @@ is_boz_constant (gfc_expr *a)
} }
/* Convert a octal string into a binary string. This is used in the
fallback conversion of an octal string to a REAL. */
static char *
oct2bin(int nbits, char *oct)
{
const char bits[8][5] = {
"000", "001", "010", "011", "100", "101", "110", "111"};
char *buf, *bufp;
int i, j, n;
j = nbits + 1;
if (nbits == 64) j++;
bufp = buf = XCNEWVEC (char, j + 1);
memset (bufp, 0, j + 1);
n = strlen (oct);
for (i = 0; i < n; i++, oct++)
{
j = *oct - 48;
strcpy (bufp, &bits[j][0]);
bufp += 3;
}
bufp = XCNEWVEC (char, nbits + 1);
if (nbits == 64)
strcpy (bufp, buf + 2);
else
strcpy (bufp, buf + 1);
free (buf);
return bufp;
}
/* Convert a hexidecimal string into a binary string. This is used in the
fallback conversion of a hexidecimal string to a REAL. */
static char *
hex2bin(int nbits, char *hex)
{
const char bits[16][5] = {
"0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
"1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};
char *buf, *bufp;
int i, j, n;
bufp = buf = XCNEWVEC (char, nbits + 1);
memset (bufp, 0, nbits + 1);
n = strlen (hex);
for (i = 0; i < n; i++, hex++)
{
j = *hex;
if (j > 47 && j < 58)
j -= 48;
else if (j > 64 && j < 71)
j -= 55;
else if (j > 96 && j < 103)
j -= 87;
else
gcc_unreachable ();
strcpy (bufp, &bits[j][0]);
bufp += 4;
}
return buf;
}
/* Fallback conversion of a BOZ string to REAL. */
static void
bin2real (gfc_expr *x, int kind)
{
char buf[114], *sp;
int b, i, ie, t, w;
bool sgn;
mpz_t em;
i = gfc_validate_kind (BT_REAL, kind, false);
t = gfc_real_kinds[i].digits - 1;
/* Number of bits in the exponent. */
if (gfc_real_kinds[i].max_exponent == 16384)
w = 15;
else if (gfc_real_kinds[i].max_exponent == 1024)
w = 11;
else
w = 8;
if (x->boz.rdx == 16)
sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
else if (x->boz.rdx == 8)
sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
else
sp = x->boz.str;
/* Extract sign bit. */
sgn = *sp != '0';
/* Extract biased exponent. */
memset (buf, 0, 114);
strncpy (buf, ++sp, w);
mpz_init (em);
mpz_set_str (em, buf, 2);
ie = mpz_get_si (em);
mpfr_init2 (x->value.real, t + 1);
x->ts.type = BT_REAL;
x->ts.kind = kind;
sp += w; /* Set to first digit in significand. */
b = (1 << w) - 1;
if ((i == 0 && ie == b) || (i == 1 && ie == b)
|| ((i == 2 || i == 3) && ie == b))
{
bool zeros = true;
if (i == 2) sp++;
for (; *sp; sp++)
{
if (*sp != '0')
{
zeros = false;
break;
}
}
if (zeros)
mpfr_set_inf (x->value.real, 1);
else
mpfr_set_nan (x->value.real);
}
else
{
if (i == 2)
strncpy (buf, sp, t + 1);
else
{
/* Significand with hidden bit. */
buf[0] = '1';
strncpy (&buf[1], sp, t);
}
/* Convert to significand to integer. */
mpz_set_str (em, buf, 2);
ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */
mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE);
}
if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE);
mpz_clear (em);
}
/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real () /* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
converts the string into a REAL of the appropriate kind. The treatment converts the string into a REAL of the appropriate kind. The treatment
of the sign bit is processor dependent. */ of the sign bit is processor dependent. */
...@@ -158,21 +320,31 @@ gfc_boz2real (gfc_expr *x, int kind) ...@@ -158,21 +320,31 @@ gfc_boz2real (gfc_expr *x, int kind)
buf[0] = '1'; buf[0] = '1';
} }
} }
/* Reset BOZ string to the truncated or padded version. */ /* Reset BOZ string to the truncated or padded version. */
free (x->boz.str); free (x->boz.str);
x->boz.len = len; x->boz.len = len;
x->boz.str = XCNEWVEC (char, len + 1); x->boz.str = XCNEWVEC (char, len + 1);
strncpy (x->boz.str, buf, len); strncpy (x->boz.str, buf, len);
/* Convert to widest possible integer. */ /* For some targets, the largest INTEGER in terms of bits is smaller than
gfc_boz2int (x, gfc_max_integer_kind); the bits needed to hold the REAL. Fortunately, the kind type parameter
ts.type = BT_REAL; indicates the number of bytes required to an INTEGER and a REAL. */
ts.kind = kind; if (gfc_max_integer_kind < kind)
if (!gfc_convert_boz (x, &ts))
{ {
gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where); bin2real (x, kind);
return false; }
else
{
/* Convert to widest possible integer. */
gfc_boz2int (x, gfc_max_integer_kind);
ts.type = BT_REAL;
ts.kind = kind;
if (!gfc_convert_boz (x, &ts))
{
gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
return false;
}
} }
return true; return true;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment