[RFA/Ada] Crash when trying to set value of packed array element

[Joel Brobecker <brobecker@adacore.com>]

Consider the following declaration:

   type Small is new Integer range 0 .. 2 ** 4 - 1;
   type Simple_Array is array (1 .. 4) of Small;
   pragma Pack (Simple_Array);

   SA : Simple_Array := (1, 2, 3, 4);

Trying to change the value of one of the elements in the packed array
causes the debugger to crash:

    (gdb) set sa(3) := 9
    [1]    4880 segmentation fault  gdb -q foo

The circumstances leading to the crash are as follow:

   . ada_evaluate_subexp creates a value corresponding to "sa(3)".

   . ada_evaluate_subexp then tries to assign 9 to this value, and
     for this calls value_assign (via ada_value_assign).

   . Because the array is packed, the destination value is 3 bits long,
     and as a result, value_assign uses the parent to determine that
     element byte address and offset:

      | if (value_bitsize (toval))
      |   {
      |     struct value *parent = value_parent (toval);
      |
      |     changed_addr = value_address (parent) + value_offset (toval);

The destination value (corresponding to "sa(3)") was incorrectly created
by ada-lang.c:ada_value_primitive_packed_val, because the "parent" was
left as NULL. So, when we try to dereference it to get the parent address,
GDB crashed.

The first part of the fix therefore consists in setting that field.
This required the addition of a new "setter" in value.[hc].  It fixes
the crash, but is still not sufficient for the assignment to actually
work.

The second part of the problem came from the fact that value_assign
seems to expect the "child"'s address to be equal to the parent's address,
with the difference being the offset. Unfortunately, this requirement was
not followed by ada_value_primitive_packed_val, so the second part of
the fix consisted in fixing that.

Still, this was not sufficient, because it caused a regression when
trying to perform an aggregate assignment of a packed array of packed
record.  The key element here is the nesting of packed entities.
Looking at the way ada_value_primitive_packed_val creates the value
of each sub-component, one can see that the value's offset is set
to the offset compared to the start of the parent. This was meant to
match what value_primitive_field does as well.

So, with our array of records, if the record offset was 2, and if
the field we're interested in that record is at offset 1, the record
value's offset would be set to 2, and the field value's offset would
be set to 1. But the address for both values would be left to the
array's address. This is where things start breaking down, because
the value_address function for our field value would return the
address of the array + 1, instead of + 3.

This is what causes the final issue, here, because ada-lang.c's
value_assign_to_component needs to compute the offset of the
subcomponent compared to the top-level aggregate's start address
(the array in our case). And it does so by subtracting the array's
address from the sub-component's address.  When you have two levels
of packed components, and the mid-level component is at an offset of
the top-level component, things didn't work, because the component's
address was miscomputed (the parent's offset is missing).

The fix consists is fixing value_address to match the work done by
value_primitive_field (where we ignore the parent's offset).

I'm not completely happy with the last part, but it did feel like
the safest thing to be doing without running the risk of changing
some semantics on my own.  What I can do as a followup, is see if
I can change the offset to make sure that address (value) is always
equal to value->address + value->offset, even in this packed-of-packed
case. I'd then be able to undo the change in value_address....

gdb/ChangeLog:

        * value.h (set_value_parent): Add declaration.
        * value.c (set_value_parent): New function.
        (value_address): If VALUE->PARENT is not NULL, then use it as
        the base address instead of VALUE->LOCATION.address.
        * ada-lang.c (ada_value_primitive_packed_val): Keep V's address
        the same as OBJ's address.  Adjust V's offset accordingly.
        Set V's parent.

gdb/testsuite/ChangeLog:

        * gdb.ada/set_pckd_arr_elt: New testcase.

Tested on x86_64-linux. OK to commit?

Thanks,
-- 
Joel

---
 gdb/ada-lang.c                                 |   17 +++++----
 gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp     |   47 ++++++++++++++++++++++++
 gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb |   22 +++++++++++
 gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb |   21 +++++++++++
 gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads |   22 +++++++++++
 gdb/value.c                                    |   11 +++++-
 gdb/value.h                                    |    1 +
 7 files changed, 133 insertions(+), 8 deletions(-)
 create mode 100644 gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
 create mode 100644 gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
 create mode 100644 gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
 create mode 100644 gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads

diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 349ca17..f6f51ec 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -2297,10 +2297,9 @@ ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
     }
   else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
     {
-      v = value_at (type,
-                    value_address (obj) + offset);
+      v = value_at (type, value_address (obj));
       bytes = (unsigned char *) alloca (len);
-      read_memory (value_address (v), bytes, len);
+      read_memory (value_address (v) + offset, bytes, len);
     }
   else
     {
@@ -2310,18 +2309,22 @@ ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
 
   if (obj != NULL)
     {
-      CORE_ADDR new_addr;
+      long new_offset = offset;
 
       set_value_component_location (v, obj);
-      new_addr = value_address (obj) + offset;
       set_value_bitpos (v, bit_offset + value_bitpos (obj));
       set_value_bitsize (v, bit_size);
       if (value_bitpos (v) >= HOST_CHAR_BIT)
         {
-	  ++new_addr;
+	  ++new_offset;
           set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
         }
-      set_value_address (v, new_addr);
+      set_value_offset (v, new_offset);
+
+      /* Also set the parent value.  This is needed when trying to
+	 assign a new value (in inferior memory).  */
+      set_value_parent (v, obj);
+      value_incref (obj);
     }
   else
     set_value_bitsize (v, bit_size);
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp b/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
new file mode 100644
index 0000000..7f6f1d3
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt.exp
@@ -0,0 +1,47 @@
+# Copyright 2012 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"
+
+if { [skip_ada_tests] } { return -1 }
+
+set testdir "set_pckd_arr_elt"
+set testfile "${testdir}/foo"
+set srcfile ${srcdir}/${subdir}/${testfile}.adb
+set binfile ${objdir}/${subdir}/${testfile}
+
+file mkdir ${objdir}/${subdir}/${testdir}
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable {debug}] != ""} {
+    return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/foo.adb]
+runto "foo.adb:$bp_location"
+
+gdb_test "print sa(3) := 9" " = 9"
+
+# To verify that the assignment was made correctly, we use the fact
+# that the program passes this very same element as an argument to
+# one of the functions.  So we insert a breakpoint on that function,
+# and verify that the argument value is correct.
+
+gdb_breakpoint "update_small"
+
+gdb_test "continue" \
+        "Breakpoint .*, pck\\.update_small \\(s=9\\) at .*pck.adb:.*" \
+        "continue to update_small"
+
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
new file mode 100644
index 0000000..7f4f45d
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/foo.adb
@@ -0,0 +1,22 @@
+--  Copyright 2012 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 Foo is
+   SA : Simple_Array := (1, 2, 3, 4);
+begin
+   Update_Small (SA (3));  -- STOP
+end Foo;
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
new file mode 100644
index 0000000..a2bec81
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.adb
@@ -0,0 +1,21 @@
+--  Copyright 2012 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 Update_Small (S : in out Small) is
+   begin
+      null;
+   end Update_Small;
+end Pck;
diff --git a/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads
new file mode 100644
index 0000000..6be95e2
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/set_pckd_arr_elt/pck.ads
@@ -0,0 +1,22 @@
+--  Copyright 2012 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 Pck is
+   type Small is new Integer range 0 .. 2 ** 6 - 1;
+   type Simple_Array is array (1 .. 4) of Small;
+   pragma Pack (Simple_Array);
+
+   procedure Update_Small (S : in out Small);
+end Pck;
diff --git a/gdb/value.c b/gdb/value.c
index 85ea970..75cc3bb 100644
--- a/gdb/value.c
+++ b/gdb/value.c
@@ -805,6 +805,12 @@ value_parent (struct value *value)
   return value->parent;
 }
 
+void
+set_value_parent (struct value *value, struct value *parent)
+{
+  value->parent = parent;
+}
+
 gdb_byte *
 value_contents_raw (struct value *value)
 {
@@ -1100,7 +1106,10 @@ value_address (const struct value *value)
   if (value->lval == lval_internalvar
       || value->lval == lval_internalvar_component)
     return 0;
-  return value->location.address + value->offset;
+  if (value->parent != NULL)
+    return value_address (value->parent) + value->offset;
+  else
+    return value->location.address + value->offset;
 }
 
 CORE_ADDR
diff --git a/gdb/value.h b/gdb/value.h
index d4c4a83..c173b0e 100644
--- a/gdb/value.h
+++ b/gdb/value.h
@@ -74,6 +74,7 @@ extern void set_value_bitpos (struct value *, int bit);
    bitfields.  */
 
 struct value *value_parent (struct value *);
+extern void set_value_parent (struct value *value, struct value *parent);
 
 /* Describes offset of a value within lval of a structure in bytes.
    If lval == lval_memory, this is an offset to the address.  If lval
-- 
1.7.1