Fix fixed-point binary operation type handling

Testing showed that gdb was not correctly handling some fixed-point
binary operations correctly.

Addition and subtraction worked by casting the result to the type of
left hand operand.  So, "fixed+int" had a different type -- and
different value -- from "int+fixed".

Furthermore, for multiplication and division, it does not make sense
to first cast both sides to the fixed-point type.  For example, this
can prevent "f * 1" from yielding "f", if 1 is not in the domain of
"f".  Instead, this patch changes gdb to use the value.  (This is
somewhat different from Ada semantics, as those can yield a "universal
fixed point".)

This includes a new test case.  It is only run in "minimal" mode, as
the old-style fixed point works differently, and is obsolete, so I
have no plans to change it.

gdb/ChangeLog
2021-01-06  Tom Tromey  <tromey@adacore.com>

	* ada-lang.c (ada_evaluate_subexp) <BINOP_ADD, BINOP_SUB>:
	Do not cast result.
	* valarith.c (fixed_point_binop): Handle multiplication
	and division specially.
	* valops.c (value_to_gdb_mpq): New function.
	(value_cast_to_fixed_point): Use it.

gdb/testsuite/ChangeLog
2021-01-06  Tom Tromey  <tromey@adacore.com>

	* gdb.ada/fixed_points/pck.ads (Delta4): New constant.
	(FP4_Type): New type.
	(FP4_Var): New variable.
	* gdb.ada/fixed_points/fixed_points.adb: Update.
	* gdb.ada/fixed_points.exp: Add tests for binary operators.

9 files changed, 152 insertions, 60 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 4a7d801edb6..44dfabf62d4 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,12 @@
+2021-01-06  Tom Tromey  <tromey@adacore.com>
+
+	* ada-lang.c (ada_evaluate_subexp) <BINOP_ADD, BINOP_SUB>:
+	Do not cast result.
+	* valarith.c (fixed_point_binop): Handle multiplication
+	and division specially.
+	* valops.c (value_to_gdb_mpq): New function.
+	(value_cast_to_fixed_point): Use it.
+
 2021-01-05  Hannes Domani  <ssbssa@yahoo.de>
 
 	* tui/tui-winsource.c (tui_source_window_base::refresh_window):
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 8b2086109b9..3bc7bdd6388 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -10195,18 +10195,28 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
 	return (value_from_longest
 		 (value_type (arg2),
 		  value_as_long (arg1) + value_as_long (arg2)));
-      if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1))
-	   || ada_is_gnat_encoded_fixed_point_type (value_type (arg2)))
-	  && value_type (arg1) != value_type (arg2))
-	error (_("Operands of fixed-point addition must have the same type"));
-      /* Do the addition, and cast the result to the type of the first
-	 argument.  We cannot cast the result to a reference type, so if
-	 ARG1 is a reference type, find its underlying type.  */
+      /* Preserve the original type for use by the range case below.
+	 We cannot cast the result to a reference type, so if ARG1 is
+	 a reference type, find its underlying type.  */
       type = value_type (arg1);
       while (type->code () == TYPE_CODE_REF)
 	type = TYPE_TARGET_TYPE (type);
-      binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
-      return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
+      if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1))
+	  || ada_is_gnat_encoded_fixed_point_type (value_type (arg2)))
+	{
+	  if (value_type (arg1) != value_type (arg2))
+	    error (_("Operands of fixed-point addition must have the same type"));
+	}
+      else
+	binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+      arg1 = value_binop (arg1, arg2, BINOP_ADD);
+      /* We need to special-case the result of adding to a range.
+	 This is done for the benefit of "ptype".  gdb's Ada support
+	 historically used the LHS to set the result type here, so
+	 preserve this behavior.  */
+      if (type->code () == TYPE_CODE_RANGE)
+	arg1 = value_cast (type, arg1);
+      return arg1;
 
     case BINOP_SUB:
       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
@@ -10221,19 +10231,29 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
 	return (value_from_longest
 		 (value_type (arg2),
 		  value_as_long (arg1) - value_as_long (arg2)));
-      if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1))
-	   || ada_is_gnat_encoded_fixed_point_type (value_type (arg2)))
-	  && value_type (arg1) != value_type (arg2))
-	error (_("Operands of fixed-point subtraction "
-		 "must have the same type"));
-      /* Do the substraction, and cast the result to the type of the first
-	 argument.  We cannot cast the result to a reference type, so if
-	 ARG1 is a reference type, find its underlying type.  */
+      /* Preserve the original type for use by the range case below.
+	 We cannot cast the result to a reference type, so if ARG1 is
+	 a reference type, find its underlying type.  */
       type = value_type (arg1);
       while (type->code () == TYPE_CODE_REF)
 	type = TYPE_TARGET_TYPE (type);
-      binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
-      return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
+      if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1))
+	  || ada_is_gnat_encoded_fixed_point_type (value_type (arg2)))
+	{
+	  if (value_type (arg1) != value_type (arg2))
+	    error (_("Operands of fixed-point subtraction "
+		     "must have the same type"));
+	}
+      else
+	binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
+      arg1 = value_binop (arg1, arg2, BINOP_SUB);
+      /* We need to special-case the result of adding to a range.
+	 This is done for the benefit of "ptype".  gdb's Ada support
+	 historically used the LHS to set the result type here, so
+	 preserve this behavior.  */
+      if (type->code () == TYPE_CODE_RANGE)
+	arg1 = value_cast (type, arg1);
+      return arg1;
 
     case BINOP_MUL:
     case BINOP_DIV:
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index d3c6e952132..8d5a2ee4599 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2021-01-06  Tom Tromey  <tromey@adacore.com>
+
+	* gdb.ada/fixed_points/pck.ads (Delta4): New constant.
+	(FP4_Type): New type.
+	(FP4_Var): New variable.
+	* gdb.ada/fixed_points/fixed_points.adb: Update.
+	* gdb.ada/fixed_points.exp: Add tests for binary operators.
+
 2021-01-06  Simon Marchi  <simon.marchi@polymtl.ca>
 
 	* lib/gdb.exp (gdb_test_sequence): Accept -prompt switch.
diff --git a/gdb/testsuite/gdb.ada/fixed_points.exp b/gdb/testsuite/gdb.ada/fixed_points.exp
index 8f76382d126..0d244534975 100644
--- a/gdb/testsuite/gdb.ada/fixed_points.exp
+++ b/gdb/testsuite/gdb.ada/fixed_points.exp
@@ -107,4 +107,21 @@ foreach_with_prefix scenario {all minimal} {
 	    pass $gdb_test_name
 	}
     }
+
+    # One of the benefits of minimal encoding is that operations work
+    # a bit better.
+    if {$scenario == "minimal"} {
+	gdb_test "print fp2_var + 0" \
+	    " = -0.01"
+	gdb_test "print 0 + fp2_var" \
+	    " = -0.01"
+	gdb_test "print fp2_var - 0" \
+	    " = -0.01"
+
+	set fp4 "= 2e-07"
+	gdb_test "print fp4_var" $fp4
+	gdb_test "print fp4_var * 1" $fp4
+	gdb_test "print 1 * fp4_var" $fp4
+	gdb_test "print fp4_var / 1" $fp4
+    }
 }
diff --git a/gdb/testsuite/gdb.ada/fixed_points/fixed_points.adb b/gdb/testsuite/gdb.ada/fixed_points/fixed_points.adb
index be8f72047ae..cc2c6377761 100644
--- a/gdb/testsuite/gdb.ada/fixed_points/fixed_points.adb
+++ b/gdb/testsuite/gdb.ada/fixed_points/fixed_points.adb
@@ -63,4 +63,5 @@ begin
    Do_Nothing (FP1_Var'Address);
    Do_Nothing (FP2_Var'Address);
    Do_Nothing (FP3_Var'Address);
+   Do_Nothing (FP4_Var'Address);
 end Fixed_Points;
diff --git a/gdb/testsuite/gdb.ada/fixed_points/pck.ads b/gdb/testsuite/gdb.ada/fixed_points/pck.ads
index c30279c690f..b5c1bc01c44 100644
--- a/gdb/testsuite/gdb.ada/fixed_points/pck.ads
+++ b/gdb/testsuite/gdb.ada/fixed_points/pck.ads
@@ -25,6 +25,11 @@ package Pck is
    type FP3_Type is delta 0.1 range 0.0 .. 1.0 with Small => 0.1/3.0;
    FP3_Var : FP3_Type := 0.1;
 
+   Delta4 : constant := 0.000_000_1;
+   type FP4_Type is delta Delta4 range 0.0 .. Delta4 * 10
+      with Small => Delta4 / 3.0;
+   FP4_Var : FP4_Type := 2 * Delta4;
+
    procedure Do_Nothing (A : System.Address);
 end pck;
 
diff --git a/gdb/valarith.c b/gdb/valarith.c
index f3cc500eb18..81d48aae82a 100644
--- a/gdb/valarith.c
+++ b/gdb/valarith.c
@@ -903,27 +903,41 @@ fixed_point_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
   struct gdbarch *gdbarch = get_type_arch (type1);
   struct value *val;
 
+  gdb_mpq v1, v2, res;
+
   gdb_assert (is_fixed_point_type (type1) || is_fixed_point_type (type2));
-  if (!is_fixed_point_type (type1))
+  if (op == BINOP_MUL || op == BINOP_DIV)
     {
-      arg1 = value_cast (type2, arg1);
-      type1 = type2;
+      v1 = value_to_gdb_mpq (arg1);
+      v2 = value_to_gdb_mpq (arg2);
+
+      /* The code below uses TYPE1 for the result type, so make sure
+	 it is set properly.  */
+      if (!is_fixed_point_type (type1))
+	type1 = type2;
     }
-  if (!is_fixed_point_type (type2))
+  else
     {
-      arg2 = value_cast (type1, arg2);
-      type2 = type1;
-    }
+      if (!is_fixed_point_type (type1))
+	{
+	  arg1 = value_cast (type2, arg1);
+	  type1 = type2;
+	}
+      if (!is_fixed_point_type (type2))
+	{
+	  arg2 = value_cast (type1, arg2);
+	  type2 = type1;
+	}
 
-  gdb_mpq v1, v2, res;
-  v1.read_fixed_point (gdb::make_array_view (value_contents (arg1),
-					     TYPE_LENGTH (type1)),
-		       type_byte_order (type1), type1->is_unsigned (),
-		       type1->fixed_point_scaling_factor ());
-  v2.read_fixed_point (gdb::make_array_view (value_contents (arg2),
-					     TYPE_LENGTH (type2)),
-		       type_byte_order (type2), type2->is_unsigned (),
-		       type2->fixed_point_scaling_factor ());
+      v1.read_fixed_point (gdb::make_array_view (value_contents (arg1),
+						 TYPE_LENGTH (type1)),
+			   type_byte_order (type1), type1->is_unsigned (),
+			   type1->fixed_point_scaling_factor ());
+      v2.read_fixed_point (gdb::make_array_view (value_contents (arg2),
+						 TYPE_LENGTH (type2)),
+			   type_byte_order (type2), type2->is_unsigned (),
+			   type2->fixed_point_scaling_factor ());
+    }
 
   auto fixed_point_to_value = [type1] (const gdb_mpq &fp)
     {
diff --git a/gdb/valops.c b/gdb/valops.c
index 455cf7d5d13..6a9cbdce710 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -331,6 +331,39 @@ value_cast_pointers (struct type *type, struct value *arg2,
   return arg2;
 }
 
+/* See value.h.  */
+
+gdb_mpq
+value_to_gdb_mpq (struct value *value)
+{
+  struct type *type = check_typedef (value_type (value));
+
+  gdb_mpq result;
+  if (is_floating_type (type))
+    {
+      double d = target_float_to_host_double (value_contents (value),
+					      type);
+      mpq_set_d (result.val, d);
+    }
+  else
+    {
+      gdb_assert (is_integral_type (type)
+		  || is_fixed_point_type (type));
+
+      gdb_mpz vz;
+      vz.read (gdb::make_array_view (value_contents (value),
+				     TYPE_LENGTH (type)),
+	       type_byte_order (type), type->is_unsigned ());
+      mpq_set_z (result.val, vz.val);
+
+      if (is_fixed_point_type (type))
+	mpq_mul (result.val, result.val,
+		 type->fixed_point_scaling_factor ().val);
+    }
+
+  return result;
+}
+
 /* Assuming that TO_TYPE is a fixed point type, return a value
    corresponding to the cast of FROM_VAL to that type.  */
 
@@ -342,34 +375,14 @@ value_cast_to_fixed_point (struct type *to_type, struct value *from_val)
   if (from_type == to_type)
     return from_val;
 
-  gdb_mpq vq;
-
-  /* Extract the value as a rational number.  */
-
-  if (is_floating_type (from_type))
-    {
-      double d = target_float_to_host_double (value_contents (from_val),
-					      from_type);
-      mpq_set_d (vq.val, d);
-    }
-
-  else if (is_integral_type (from_type) || is_fixed_point_type (from_type))
-    {
-      gdb_mpz vz;
-
-      vz.read (gdb::make_array_view (value_contents (from_val),
-				     TYPE_LENGTH (from_type)),
-	       type_byte_order (from_type), from_type->is_unsigned ());
-      mpq_set_z (vq.val, vz.val);
-
-      if (is_fixed_point_type (from_type))
-	mpq_mul (vq.val, vq.val, from_type->fixed_point_scaling_factor ().val);
-    }
-
-  else
+  if (!is_floating_type (from_type)
+      && !is_integral_type (from_type)
+      && !is_fixed_point_type (from_type))
     error (_("Invalid conversion from type %s to fixed point type %s"),
 	   from_type->name (), to_type->name ());
 
+  gdb_mpq vq = value_to_gdb_mpq (from_val);
+
   /* Divide that value by the scaling factor to obtain the unscaled
      value, first in rational form, and then in integer form.  */
 
diff --git a/gdb/value.h b/gdb/value.h
index 7bf5654ae43..39e94f45ea6 100644
--- a/gdb/value.h
+++ b/gdb/value.h
@@ -23,6 +23,7 @@
 #include "frame.h"		/* For struct frame_id.  */
 #include "extension.h"
 #include "gdbsupport/gdb_ref_ptr.h"
+#include "gmp-utils.h"
 
 struct block;
 struct expression;
@@ -1222,4 +1223,8 @@ extern struct value *call_xmethod (struct value *method,
    exiting (e.g., on quit_force).  */
 extern void finalize_values ();
 
+/* Convert VALUE to a gdb_mpq.  The caller must ensure that VALUE is
+   of floating-point, fixed-point, or integer type.  */
+extern gdb_mpq value_to_gdb_mpq (struct value *value);
+
 #endif /* !defined (VALUE_H) */