[binutils-gdb] Implement Ada 2022 delta aggregates

[binutils-gdb] Implement Ada 2022 delta aggregates

[Tom Tromey]

https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=7e949f08700b077b78e955c653eb4e9455027101

commit 7e949f08700b077b78e955c653eb4e9455027101
Author: Tom Tromey <tromey@adacore.com>
Date:   Thu Feb 29 13:54:19 2024 -0700

    Implement Ada 2022 delta aggregates
    
    Ada 2022 includes a "delta aggregates" feature that can sometimes
    simplify aggregate creation.  This patch implements this feature for
    GDB.

Diff:
---
 gdb/ada-exp.h                               |  8 +++++
 gdb/ada-exp.y                               | 12 ++++++-
 gdb/ada-lang.c                              | 42 ++++++++++++++++++++++---
 gdb/ada-lex.l                               |  2 ++
 gdb/testsuite/gdb.ada/delta-assign.exp      | 49 +++++++++++++++++++++++++++++
 gdb/testsuite/gdb.ada/delta-assign/main.adb | 24 ++++++++++++++
 gdb/testsuite/gdb.ada/delta-assign/pck.adb  | 23 ++++++++++++++
 gdb/testsuite/gdb.ada/delta-assign/pck.ads  | 42 +++++++++++++++++++++++++
 8 files changed, 197 insertions(+), 5 deletions(-)

diff --git a/gdb/ada-exp.h b/gdb/ada-exp.h
index 9abdd6f3f70..69d4e90e410 100644
--- a/gdb/ada-exp.h
+++ b/gdb/ada-exp.h
@@ -660,6 +660,10 @@ public:
   {
   }
 
+  /* This is the "with delta" form -- BASE is the base expression.  */
+  ada_aggregate_component (operation_up &&base,
+			   std::vector<ada_component_up> &&components);
+
   void assign (struct value *container,
 	       struct value *lhs, struct expression *exp,
 	       std::vector<LONGEST> &indices,
@@ -671,6 +675,10 @@ public:
 
 private:
 
+  /* If the assignment has a "with delta" clause, this is the
+     base expression.  */
+  operation_up m_base;
+  /* The individual components to assign.  */
   std::vector<ada_component_up> m_components;
 };
 
diff --git a/gdb/ada-exp.y b/gdb/ada-exp.y
index 26963f78884..2b205714d7a 100644
--- a/gdb/ada-exp.y
+++ b/gdb/ada-exp.y
@@ -453,6 +453,7 @@ static std::vector<ada_assign_up> assignments;
 %token <typed_char> CHARLIT
 %token <typed_val_float> FLOAT
 %token TRUEKEYWORD FALSEKEYWORD
+%token WITH DELTA
 %token COLONCOLON
 %token <sval> STRING NAME DOT_ID TICK_COMPLETE DOT_COMPLETE NAME_COMPLETE
 %type <bval> block
@@ -1032,7 +1033,16 @@ block   :       NAME COLONCOLON
 	;
 
 aggregate :
-		'(' aggregate_component_list ')'  
+		'(' exp WITH DELTA aggregate_component_list ')'
+			{
+			  std::vector<ada_component_up> components
+			    = pop_components ($5);
+			  operation_up base = ada_pop ();
+
+			  push_component<ada_aggregate_component>
+			    (std::move (base), std::move (components));
+			}
+	|	'(' aggregate_component_list ')'
 			{
 			  std::vector<ada_component_up> components
 			    = pop_components ($2);
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 2a904950241..493ef3b6c7d 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -9323,10 +9323,9 @@ check_objfile (const std::unique_ptr<ada_component> &comp,
   return comp->uses_objfile (objfile);
 }
 
-/* Assign the result of evaluating ARG starting at *POS to the INDEXth
-   component of LHS (a simple array or a record).  Does not modify the
-   inferior's memory, nor does it modify LHS (unless LHS ==
-   CONTAINER).  */
+/* Assign the result of evaluating ARG to the INDEXth component of LHS
+   (a simple array or a record).  Does not modify the inferior's
+   memory, nor does it modify LHS (unless LHS == CONTAINER).  */
 
 static void
 assign_component (struct value *container, struct value *lhs, LONGEST index,
@@ -9363,6 +9362,8 @@ assign_component (struct value *container, struct value *lhs, LONGEST index,
 bool
 ada_aggregate_component::uses_objfile (struct objfile *objfile)
 {
+  if (m_base != nullptr && m_base->uses_objfile (objfile))
+    return true;
   for (const auto &item : m_components)
     if (item->uses_objfile (objfile))
       return true;
@@ -9373,6 +9374,11 @@ void
 ada_aggregate_component::dump (ui_file *stream, int depth)
 {
   gdb_printf (stream, _("%*sAggregate\n"), depth, "");
+  if (m_base != nullptr)
+    {
+      gdb_printf (stream, _("%*swith delta\n"), depth + 1, "");
+      m_base->dump (stream, depth + 2);
+    }
   for (const auto &item : m_components)
     item->dump (stream, depth + 1);
 }
@@ -9383,12 +9389,40 @@ ada_aggregate_component::assign (struct value *container,
 				 std::vector<LONGEST> &indices,
 				 LONGEST low, LONGEST high)
 {
+  if (m_base != nullptr)
+    {
+      value *base = m_base->evaluate (nullptr, exp, EVAL_NORMAL);
+      if (ada_is_direct_array_type (base->type ()))
+	base = ada_coerce_to_simple_array (base);
+      if (!types_deeply_equal (container->type (), base->type ()))
+	error (_("Type mismatch in delta aggregate"));
+      value_assign_to_component (container, container, base);
+    }
+
   for (auto &item : m_components)
     item->assign (container, lhs, exp, indices, low, high);
 }
 
 /* See ada-exp.h.  */
 
+ada_aggregate_component::ada_aggregate_component
+     (operation_up &&base, std::vector<ada_component_up> &&components)
+       : m_base (std::move (base)),
+	 m_components (std::move (components))
+{
+  for (const auto &component : m_components)
+    if (dynamic_cast<const ada_others_component *> (component.get ())
+	!= nullptr)
+      {
+	/* It's invalid and nonsensical to have 'others => ...' with a
+	   delta aggregate.  It was simpler to enforce this
+	   restriction here as opposed to in the parser.  */
+	error (_("'others' invalid in delta aggregate"));
+      }
+}
+
+/* See ada-exp.h.  */
+
 value *
 ada_aggregate_operation::assign_aggregate (struct value *container,
 					   struct value *lhs,
diff --git a/gdb/ada-lex.l b/gdb/ada-lex.l
index 828ff9a9215..c54cd5e452a 100644
--- a/gdb/ada-lex.l
+++ b/gdb/ada-lex.l
@@ -225,6 +225,7 @@ thread{WHITE}+{DIG} {
 
 abs		{ return ABS; }
 and		{ return _AND_; }
+delta		{ return DELTA; }
 else		{ return ELSE; }
 in		{ return IN; }
 mod		{ return MOD; }
@@ -235,6 +236,7 @@ or		{ return OR; }
 others          { return OTHERS; }
 rem		{ return REM; }
 then		{ return THEN; }
+with		{ return WITH; }
 xor		{ return XOR; }
 
 	/* BOOLEAN "KEYWORDS" */
diff --git a/gdb/testsuite/gdb.ada/delta-assign.exp b/gdb/testsuite/gdb.ada/delta-assign.exp
new file mode 100644
index 00000000000..d7339523e29
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/delta-assign.exp
@@ -0,0 +1,49 @@
+# Copyright 2024 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/>.
+
+load_lib "ada.exp"
+
+require allow_ada_tests
+
+standard_ada_testfile main
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug]] != "" } {
+    return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/main.adb]
+runto "main.adb:$bp_location"
+
+gdb_test "print local := (pck.v1 with delta b => 23)" \
+    [string_to_regexp " = (a => 23, b => 23)"] \
+    "delta aggregate record"
+
+gdb_test "print local := (pck.v1 with delta others => 23)" \
+    "'others' invalid in delta aggregate" \
+    "invalid record delta aggregate"
+
+gdb_test "print local := (pck.v3 with delta b => 19)" \
+    "Type mismatch in delta aggregate" \
+    "wrong type in delta aggregate"
+
+gdb_test "print a := (pck.a1 with delta 2 => 7)" \
+    [string_to_regexp " = (2, 7, 6)"] \
+    "delta aggregate array"
+
+gdb_test "print a := (pck.a1 with delta others => 88)" \
+    "'others' invalid in delta aggregate" \
+    "invalid array delta aggregate"
diff --git a/gdb/testsuite/gdb.ada/delta-assign/main.adb b/gdb/testsuite/gdb.ada/delta-assign/main.adb
new file mode 100644
index 00000000000..75d51cf2249
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/delta-assign/main.adb
@@ -0,0 +1,24 @@
+--  Copyright 2024 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/>.
+
+with pck; use pck;
+
+procedure Main is
+   Local : Record_Type := (A => 1, B => 2);
+   A : Array_Type := (1, 3, 5);
+begin
+   Do_Nothing (Local'Address);  -- STOP
+   Do_Nothing (A'Address);
+end Main;
diff --git a/gdb/testsuite/gdb.ada/delta-assign/pck.adb b/gdb/testsuite/gdb.ada/delta-assign/pck.adb
new file mode 100644
index 00000000000..14580e66be1
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/delta-assign/pck.adb
@@ -0,0 +1,23 @@
+--  Copyright 2024 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/>.
+
+package body Pck is
+
+   procedure Do_Nothing (A : System.Address) is
+   begin
+      null;
+   end Do_Nothing;
+
+end Pck;
diff --git a/gdb/testsuite/gdb.ada/delta-assign/pck.ads b/gdb/testsuite/gdb.ada/delta-assign/pck.ads
new file mode 100644
index 00000000000..6f09a8e2c9d
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/delta-assign/pck.ads
@@ -0,0 +1,42 @@
+--  Copyright 2024 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/>.
+
+with System;
+
+package Pck is
+
+   type Record_Type is record
+      A : Integer;
+      B : Integer;
+   end record;
+
+   V1 : Record_Type := (A => 23, B => 24);
+   V2 : Record_Type := (A => 47, B => 91);
+
+   type Other_Record_Type is record
+      A : Integer;
+      B : Integer;
+      C : Integer;
+   end record;
+
+   V3 : Other_Record_Type := (A => 47, B => 91, C => 102);
+
+   type Array_Type is array (1 .. 3) of Integer;
+
+   A1 : Array_Type := (2, 4, 6);
+
+   procedure Do_Nothing (A : System.Address);
+
+end Pck;