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.

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;
 };
 

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);

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
+/* Assign the result of evaluating ARG to the INDEXth component of LHS
-   component of LHS (a simple array or a record).  Does not modify the
+   (a simple array or a record).  Does not modify the inferior's
-   inferior's memory, nor does it modify LHS (unless LHS ==
+   memory, nor does it modify LHS (unless LHS == CONTAINER).  */
-   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,

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" */

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"

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;

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;

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;