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

2 files changed, 189 insertions, 8 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3eb02c2..534ae35 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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>
 
 	PR fortran/90985
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 376edd3..0204961 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -55,6 +55,7 @@ gfc_invalid_boz (const char *msg, locus *loc)
 
 
 /* Issue an error for an illegal BOZ argument.  */
+
 static bool
 illegal_boz_arg (gfc_expr *x)
 {
@@ -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 () 
    converts the string into a REAL of the appropriate kind.  The treatment
    of the sign bit is processor dependent.  */
@@ -158,21 +320,31 @@ gfc_boz2real (gfc_expr *x, int kind)
 	    buf[0] = '1';
 	}
     }
- 
+
   /* Reset BOZ string to the truncated or padded version.  */
   free (x->boz.str);
   x->boz.len = len;
   x->boz.str = XCNEWVEC (char, len + 1);
   strncpy (x->boz.str, buf, len);
 
-  /* 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))
+  /* For some targets, the largest INTEGER in terms of bits is smaller than
+     the bits needed to hold the REAL.  Fortunately, the kind type parameter
+     indicates the number of bytes required to an INTEGER and a REAL.  */
+  if (gfc_max_integer_kind < kind)
     {
-      gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
-      return false;
+      bin2real (x, kind);
+    }
+  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;