Implement Ada 2022 iterated assignment

Ada 2022 includes iterated assignment for array initialization.  This
patch implements a subset of this for gdb.  In particular, only arrays
with integer index types really work -- currently there's no decent
way to get the index type in EVAL_AVOID_SIDE_EFFECTS mode during
parsing.  Fixing this probably requires the Ada parser to take a
somewhat more sophisticated approach to type resolution; and while
this would help fix another bug in this area, this patch is already
useful without it.

gdb/ada-exp.h

@@ -611,6 +611,15 @@ struct aggregate_assigner
      to.  */
   std::vector<LONGEST> indices;
 
+private:
+
+  /* The current index value.  This is only valid during the 'assign'
+     operation and is part of the implementation of iterated component
+     association.  */
+  LONGEST m_current_index = 0;
+
+public:
+
   /* 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).  */
@@ -620,6 +629,10 @@ struct aggregate_assigner
      [ INDICES[0] .. INDICES[1] ],...  The resulting intervals do not
      overlap.  */
   void add_interval (LONGEST low, LONGEST high);
+
+  /* Return the current index as a value, using the index type of
+     LHS.  */
+  value *current_value () const;
 };
 
 /* This abstract class represents a single component in an Ada
@@ -800,16 +813,80 @@ public:
     m_assocs = std::move (assoc);
   }
 
+  /* Set the underlying operation  */
+  void set_operation (operation_up op)
+  { m_op = std::move (op); }
+
+  /* Set the index variable name for an iterated association.  */
+  void set_name (std::string &&name)
+  { m_name = std::move (name); }
+
+  /* The name of this choice component.  This is empty unless this is
+     an iterated association.  */
+  const std::string &name () const
+  { return m_name; }
+
   void assign (aggregate_assigner &assigner) override;
 
   bool uses_objfile (struct objfile *objfile) override;
 
   void dump (ui_file *stream, int depth) override;
 
+  /* Return the current value of the index variable.  This may only be
+     called underneath a call to 'assign'.  */
+  value *current_value () const
+  { return m_assigner->current_value (); }
+
 private:
 
   std::vector<ada_association_up> m_assocs;
   operation_up m_op;
+
+  /* Name of the variable used for iteration.  This isn't needed for
+     evaluation, only for debug dumping.  This is the empty string for
+     ordinary (non-iterated) choices.  */
+  std::string m_name;
+
+  /* A pointer to the current assignment operation; only valid when in
+     a call to the 'assign' method.  This is used to find the index
+     variable value during the evaluation of the RHS of the =>, via
+     ada_index_var_operation.  */
+  const aggregate_assigner *m_assigner = nullptr;
+};
+
+/* Implement the index variable for iterated component
+   association.  */
+class ada_index_var_operation : public operation
+{
+public:
+
+  ada_index_var_operation ()
+  { }
+
+  /* Link this variable to the choices object.  May only be called
+     once.  */
+  void set_choices (ada_choices_component *var)
+  {
+    gdb_assert (m_var == nullptr && var != nullptr);
+    m_var = var;
+  }
+
+  value *evaluate (struct type *expect_type,
+		   struct expression *exp,
+		   enum noside noside) override;
+
+  enum exp_opcode opcode () const override
+  {
+    /* It doesn't really matter.  */
+    return OP_VAR_VALUE;
+  }
+
+  void dump (struct ui_file *stream, int depth) const override;
+
+private:
+
+  /* The choices component that introduced the index variable.  */
+  ada_choices_component *m_var = nullptr;
 };
 
 /* An association that uses a discrete range.  */

gdb/ada-exp.y

@@ -421,6 +421,10 @@ typedef std::unique_ptr<ada_assign_operation> ada_assign_up;
    to implement '@', the target name symbol.  */
 static std::vector<ada_assign_up> assignments;
 
+/* Track currently active iterated assignment names.  */
+static std::unordered_map<std::string, std::vector<ada_index_var_operation *>>
+     iterated_associations;
+
 %}
 
 %union
@@ -487,7 +491,7 @@ static std::vector<ada_assign_up> assignments;
     forces a.b.c, e.g., to be LEFT-associated.  */
 %right '.' '(' '[' DOT_ID DOT_COMPLETE
 
-%token NEW OTHERS
+%token NEW OTHERS FOR
 
 
 %%
@@ -1097,6 +1101,33 @@ component_group :
 			  ada_choices_component *choices = choice_component ();
 			  choices->set_associations (pop_associations ($1));
 			}
+	|	FOR NAME IN
+			{
+			  std::string name = copy_name ($2);
+
+			  auto iter = iterated_associations.find (name);
+			  if (iter != iterated_associations.end ())
+			    error (_("Nested use of index parameter '%s'"),
+				   name.c_str ());
+
+			  iterated_associations[name] = {};
+			}
+		component_associations
+			{
+			  std::string name = copy_name ($2);
+
+			  ada_choices_component *choices = choice_component ();
+			  choices->set_associations (pop_associations ($5));
+
+			  auto iter = iterated_associations.find (name);
+			  gdb_assert (iter != iterated_associations.end ());
+			  for (ada_index_var_operation *var : iter->second)
+			    var->set_choices (choices);
+
+			  iterated_associations.erase (name);
+
+			  choices->set_name (std::move (name));
+			}
 	;
 
 /* We use this somewhat obscure definition in order to handle NAME => and
@@ -1206,6 +1237,7 @@ ada_parse (struct parser_state *par_state)
   associations.clear ();
   int_storage.clear ();
   assignments.clear ();
+  iterated_associations.clear ();
 
   int result = yyparse ();
   if (!result)
@@ -1651,10 +1683,22 @@ write_var_or_type (struct parser_state *par_state,
   char *encoded_name;
   int name_len;
 
-  if (block == NULL)
-    block = par_state->expression_context_block;
-
   std::string name_storage = ada_encode (name0.ptr);
+
+  if (block == nullptr)
+    {
+      auto iter = iterated_associations.find (name_storage);
+      if (iter != iterated_associations.end ())
+	{
+	  auto op = std::make_unique<ada_index_var_operation> ();
+	  iter->second.push_back (op.get ());
+	  par_state->push (std::move (op));
+	  return nullptr;
+	}
+
+      block = par_state->expression_context_block;
+    }
+
   name_len = name_storage.size ();
   encoded_name = obstack_strndup (&temp_parse_space, name_storage.c_str (),
 				  name_len);

gdb/ada-lang.c

@@ -9342,6 +9342,8 @@ aggregate_assigner::assign (LONGEST index, operation_up &arg)
       elt = ada_to_fixed_value (elt);
     }
 
+  scoped_restore save_index = make_scoped_restore (&m_current_index, index);
+
   ada_aggregate_operation *ag_op
     = dynamic_cast<ada_aggregate_operation *> (arg.get ());
   if (ag_op != nullptr)
@@ -9352,6 +9354,18 @@ aggregate_assigner::assign (LONGEST index, operation_up &arg)
 					      EVAL_NORMAL));
 }
 
+/* See ada-exp.h.  */
+
+value *
+aggregate_assigner::current_value () const
+{
+  /* Note that using an integer type here is incorrect -- the type
+     should be the array's index type.  Unfortunately, though, this
+     isn't currently available during parsing and type resolution.  */
+  struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
+  return value_from_longest (index_type, m_current_index);
+}
+
 bool
 ada_aggregate_component::uses_objfile (struct objfile *objfile)
 {
@@ -9597,8 +9611,15 @@ ada_choices_component::uses_objfile (struct objfile *objfile)
 void
 ada_choices_component::dump (ui_file *stream, int depth)
 {
-  gdb_printf (stream, _("%*sChoices:\n"), depth, "");
+  if (m_name.empty ())
+    gdb_printf (stream, _("%*sChoices:\n"), depth, "");
+  else
+    {
+      gdb_printf (stream, _("%*sIterated choices:\n"), depth, "");
+      gdb_printf (stream, _("%*sName: %s\n"), depth + 1, "", m_name.c_str ());
+    }
   m_op->dump (stream, depth + 1);
+
   for (const auto &item : m_assocs)
     item->dump (stream, depth + 1);
 }
@@ -9610,10 +9631,36 @@ ada_choices_component::dump (ui_file *stream, int depth)
 void
 ada_choices_component::assign (aggregate_assigner &assigner)
 {
+  scoped_restore save_index = make_scoped_restore (&m_assigner, &assigner);
   for (auto &item : m_assocs)
     item->assign (assigner, m_op);
 }
 
+void
+ada_index_var_operation::dump (struct ui_file *stream, int depth) const
+{
+  gdb_printf (stream, _("%*sIndex variable: %s\n"), depth, "",
+	      m_var->name ().c_str ());
+}
+
+value *
+ada_index_var_operation::evaluate (struct type *expect_type,
+				   struct expression *exp,
+				   enum noside noside)
+{
+  if (noside == EVAL_AVOID_SIDE_EFFECTS)
+    {
+      /* Note that using an integer type here is incorrect -- the type
+	 should be the array's index type.  Unfortunately, though,
+	 this isn't currently available during parsing and type
+	 resolution.  */
+      struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
+      return value::zero (index_type, not_lval);
+    }
+
+  return m_var->current_value ();
+}
+
 bool
 ada_others_component::uses_objfile (struct objfile *objfile)
 {

gdb/ada-lex.l

@@ -227,6 +227,7 @@ abs		{ return ABS; }
 and		{ return _AND_; }
 delta		{ return DELTA; }
 else		{ return ELSE; }
+for		{ return FOR; }
 in		{ return IN; }
 mod		{ return MOD; }
 new		{ return NEW; }

gdb/testsuite/gdb.ada/iterated-assign.exp

@@ -0,0 +1,37 @@
+# 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 a1 := (for i in 1..4 => 2 * i + 1)" \
+    " = \\(3, 5, 7, 9\\)" \
+    "simple iterated assignment"
+
+gdb_test "print a2 := (for i in 1..2 => (for j in 1..2 => 3 * i + j))" \
+    " = \\(\\(4, 5\\), \\(7, 8\\)\\)" \
+    "nested iterated assignment"

gdb/testsuite/gdb.ada/iterated-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
+   A1 : Other_Array_Type := (2, 4, 6, 8);
+   A2 : MD_Array_Type := ((1, 2), (3, 4));
+begin
+   Do_Nothing (A1'Address);  -- STOP
+   Do_Nothing (A2'Address);
+end Main;

gdb/testsuite/gdb.ada/iterated-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/iterated-assign/pck.ads

@@ -0,0 +1,26 @@
+--  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 Other_Array_Type is array (1 .. 4) of Integer;
+
+   type MD_Array_Type is array (1 .. 2, 1 .. 2) of Integer;
+
+   procedure Do_Nothing (A : System.Address);
+
+end Pck;