Implement real literal extension for Ada

Sometimes it is convenient to be able to specify the exact bits of a
floating-point literal.  For example, you may want to set a
floating-point register to a denormalized value, or to a particular
NaN.

In C, you can do this by combining the "{}" cast with an array
literal, like:

    (gdb) p {double}{0x576488BDD2AE9FFE}
    $1 = 9.8765449999999996e+112

This patch adds a somewhat similar idea to Ada.  It extends the lexer
to allow "l" and "f" suffixes in a based literal.  The "f" indicates a
floating-point literal, and the "l"s control the size of the
floating-point type.

Note that this differs from Ada's based real literals.  I believe
those can also be used to control the bits of a floating-point value,
but they are a bit more cumbersome to use (simplest is binary but
that's also very lengthy).  Also, these aren't implemented in GDB.

I chose not to allow this extension to work with based integer
literals with exponents.  That didn't seem very useful.

5 files changed, 174 insertions, 20 deletions

diff --git a/gdb/NEWS b/gdb/NEWS
index 068a6c4..8fce31c 100644
--- a/gdb/NEWS
+++ b/gdb/NEWS
@@ -142,6 +142,14 @@ info win
   This command now includes information about the width of the tui
   windows in its output.
 
+* GDB's Ada parser now supports an extension for specifying the exact
+  byte contents of a floating-point literal.  This can be useful for
+  setting floating-point registers to a precise value without loss of
+  precision.  The syntax is an extension of the based literal syntax.
+  Use, e.g., "16lf#0123abcd#" -- the number of "l"s controls the width
+  of the floating-point type, and the "f" is the marker for floating
+  point.
+
 * New targets
 
 GNU/Linux/LoongArch    loongarch*-*-linux*
diff --git a/gdb/ada-lex.l b/gdb/ada-lex.l
index e4f18f1..27470a7 100644
--- a/gdb/ada-lex.l
+++ b/gdb/ada-lex.l
@@ -122,7 +122,11 @@ static int paren_depth;
 				      e_ptr + 1);
 		 }
 
-{NUM10}"#"{HEXDIG}({HEXDIG}|_)*"#" {
+	/* The "llf" is a gdb extension to allow a floating-point
+	   constant to be written in some other base.  The
+	   floating-point number is formed by reinterpreting the
+	   bytes, allowing direct control over the bits.  */
+{NUM10}(l{0,2}f)?"#"{HEXDIG}({HEXDIG}|_)*"#" {
 		   canonicalizeNumeral (numbuf, yytext);
 		   return processInt (pstate, numbuf, strchr (numbuf, '#') + 1,
 				      NULL);
@@ -347,18 +351,36 @@ static int
 processInt (struct parser_state *par_state, const char *base0,
 	    const char *num0, const char *exp0)
 {
-  ULONGEST result;
   long exp;
   int base;
-  const char *trailer;
+  /* For the based literal with an "f" prefix, we'll return a
+     floating-point number.  This counts the the number of "l"s seen,
+     to decide the width of the floating-point number to return.  -1
+     means no "f".  */
+  int floating_point_l_count = -1;
 
   if (base0 == NULL)
     base = 10;
   else
     {
-      base = strtol (base0, (char **) NULL, 10);
+      char *end_of_base;
+      base = strtol (base0, &end_of_base, 10);
       if (base < 2 || base > 16)
 	error (_("Invalid base: %d."), base);
+      while (*end_of_base == 'l')
+	{
+	  ++floating_point_l_count;
+	  ++end_of_base;
+	}
+      /* This assertion is ensured by the pattern.  */
+      gdb_assert (floating_point_l_count == -1 || *end_of_base == 'f');
+      if (*end_of_base == 'f')
+	{
+	  ++end_of_base;
+	  ++floating_point_l_count;
+	}
+      /* This assertion is ensured by the pattern.  */
+      gdb_assert (*end_of_base == '#');
     }
 
   if (exp0 == NULL)
@@ -366,26 +388,62 @@ processInt (struct parser_state *par_state, const char *base0,
   else
     exp = strtol(exp0, (char **) NULL, 10);
 
-  errno = 0;
-  result = strtoulst (num0, &trailer, base);
-  if (errno == ERANGE)
-    error (_("Integer literal out of range"));
-  if (isxdigit(*trailer))
-    error (_("Invalid digit `%c' in based literal"), *trailer);
+  gdb_mpz result;
+  while (isxdigit (*num0))
+    {
+      int dig = fromhex (*num0);
+      if (dig >= base)
+	error (_("Invalid digit `%c' in based literal"), *num0);
+      mpz_mul_ui (result.val, result.val, base);
+      mpz_add_ui (result.val, result.val, dig);
+      ++num0;
+    }
 
   while (exp > 0)
     {
-      if (result > (ULONG_MAX / base))
-	error (_("Integer literal out of range"));
-      result *= base;
+      mpz_mul_ui (result.val, result.val, base);
       exp -= 1;
     }
 
-  if ((result >> (gdbarch_int_bit (par_state->gdbarch ())-1)) == 0)
+  if (floating_point_l_count > -1)
+    {
+      struct type *fp_type;
+      if (floating_point_l_count == 0)
+	fp_type = language_lookup_primitive_type (par_state->language (),
+						  par_state->gdbarch (),
+						  "float");
+      else if (floating_point_l_count == 1)
+	fp_type = language_lookup_primitive_type (par_state->language (),
+						  par_state->gdbarch (),
+						  "long_float");
+      else
+	{
+	  /* This assertion is ensured by the pattern.  */
+	  gdb_assert (floating_point_l_count == 2);
+	  fp_type = language_lookup_primitive_type (par_state->language (),
+						    par_state->gdbarch (),
+						    "long_long_float");
+	}
+
+      yylval.typed_val_float.type = fp_type;
+      result.write (gdb::make_array_view (yylval.typed_val_float.val,
+					  TYPE_LENGTH (fp_type)),
+		    type_byte_order (fp_type),
+		    true);
+
+      return FLOAT;
+    }
+
+  gdb_mpz maxval (ULONGEST_MAX / base);
+  if (mpz_cmp (result.val, maxval.val) > 0)
+    error (_("Integer literal out of range"));
+
+  LONGEST value = result.as_integer<LONGEST> ();
+  if ((value >> (gdbarch_int_bit (par_state->gdbarch ())-1)) == 0)
     yylval.typed_val.type = type_int (par_state);
-  else if ((result >> (gdbarch_long_bit (par_state->gdbarch ())-1)) == 0)
+  else if ((value >> (gdbarch_long_bit (par_state->gdbarch ())-1)) == 0)
     yylval.typed_val.type = type_long (par_state);
-  else if (((result >> (gdbarch_long_bit (par_state->gdbarch ())-1)) >> 1) == 0)
+  else if (((value >> (gdbarch_long_bit (par_state->gdbarch ())-1)) >> 1) == 0)
     {
       /* We have a number representable as an unsigned integer quantity.
          For consistency with the C treatment, we will treat it as an
@@ -396,18 +454,18 @@ processInt (struct parser_state *par_state, const char *base0,
        */
       yylval.typed_val.type
 	= builtin_type (par_state->gdbarch ())->builtin_unsigned_long;
-      if (result & LONGEST_SIGN)
+      if (value & LONGEST_SIGN)
 	yylval.typed_val.val =
-	  (LONGEST) (result & ~LONGEST_SIGN)
+	  (LONGEST) (value & ~LONGEST_SIGN)
 	  - (LONGEST_SIGN>>1) - (LONGEST_SIGN>>1);
       else
-	yylval.typed_val.val = (LONGEST) result;
+	yylval.typed_val.val = (LONGEST) value;
       return INT;
     }
   else
     yylval.typed_val.type = type_long_long (par_state);
 
-  yylval.typed_val.val = (LONGEST) result;
+  yylval.typed_val.val = value;
   return INT;
 }
 
diff --git a/gdb/doc/gdb.texinfo b/gdb/doc/gdb.texinfo
index 5d1dcfd..063e3a1 100644
--- a/gdb/doc/gdb.texinfo
+++ b/gdb/doc/gdb.texinfo
@@ -18190,6 +18190,9 @@ context.
 Should your program
 redefine these names in a package or procedure (at best a dubious practice),
 you will have to use fully qualified names to access their new definitions.
+
+@item
+Based real literals are not implemented.
 @end itemize
 
 @node Additions to Ada
@@ -18248,6 +18251,19 @@ complex conditional breaks:
 (@value{GDBP}) condition 1 (report(i); k += 1; A(k) > 100)
 @end smallexample
 
+@item
+An extension to based literals can be used to specify the exact byte
+contents of a floating-point literal.  After the base, you can use
+from zero to two @samp{l} characters, followed by an @samp{f}.  The
+number of @samp{l} characters controls the width of the resulting real
+constant: zero means @code{Float} is used, one means
+@code{Long_Float}, and two means @code{Long_Long_Float}.
+
+@smallexample
+(@value{GDBP}) print 16f#41b80000#
+$1 = 23.0
+@end smallexample
+
 @item 
 Rather than use catenation and symbolic character names to introduce special 
 characters into strings, one may instead use a special bracket notation, 
diff --git a/gdb/testsuite/gdb.ada/float-bits.exp b/gdb/testsuite/gdb.ada/float-bits.exp
new file mode 100644
index 0000000..61db5f3
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/float-bits.exp
@@ -0,0 +1,50 @@
+# Copyright 2022 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# Test floating-point literal extension.
+
+load_lib "ada.exp"
+
+if { [skip_ada_tests] } { return -1 }
+
+standard_ada_testfile prog
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable {debug}] != ""} {
+    return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "BREAK" ${testdir}/prog.adb]
+runto "prog.adb:$bp_location"
+
+gdb_test "print 16f#41b80000#" " = 23.0"
+gdb_test "print val_float" " = 23.0"
+gdb_test "print val_float := 16f#41b80000#" " = 23.0"
+gdb_test "print val_float" " = 23.0" \
+    "print val_float after assignment"
+
+gdb_test "print 16lf#bc0d83c94fb6d2ac#" " = -2.0e-19"
+gdb_test "print val_double" " = -2.0e-19"
+gdb_test "print val_double := 16lf#bc0d83c94fb6d2ac#" " = -2.0e-19"
+gdb_test "print val_double" " = -2.0e-19" \
+    "print val_double after assignment"
+
+gdb_test "print 16llf#7FFFF7FF4054A56FA5B99019A5C8#" " = 5.0e\\+25"
+gdb_test "print val_long_double" " = 5.0e\\+25"
+gdb_test "print val_long_double := 16llf#7FFFF7FF4054A56FA5B99019A5C8#" \
+    " = 5.0e\\+25"
+gdb_test "print val_long_double" " = 5.0e\\+25" \
+    "print val_long_double after assignment"
diff --git a/gdb/testsuite/gdb.ada/float-bits/prog.adb b/gdb/testsuite/gdb.ada/float-bits/prog.adb
new file mode 100644
index 0000000..0d8c18f
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/float-bits/prog.adb
@@ -0,0 +1,22 @@
+--  Copyright 2022 Free Software Foundation, Inc.
+--
+--  This program is free software; you can redistribute it and/or modify
+--  it under the terms of the GNU General Public License as published by
+--  the Free Software Foundation; either version 3 of the License, or
+--  (at your option) any later version.
+--
+--  This program is distributed in the hope that it will be useful,
+--  but WITHOUT ANY WARRANTY; without even the implied warranty of
+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+--  GNU General Public License for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+procedure Prog is
+   Val_Float : Float := 23.0;
+   Val_Double : Long_Float := -2.0e-19;
+   Val_Long_Double : Long_Long_Float := 5.0e+25;
+begin
+   null; -- BREAK
+end Prog;