[PATCH 3/6] (Ada/MI) Fix -var-evaluate-expression for access to unconstrained arrays

[Joel Brobecker <brobecker at adacore dot com>]

From: Xavier Roirand <roirand@adacore.com>

Using this Ada code:

   type String_Access is access String;
   type Array_Of_String is array (1 .. 2) of String_Access;
   Aos : Array_Of_String := (new String'("ab"), new String'("cd"));

In GDB/MI mode, create a variable which type is Aos, evaluate it:

(gdb) -var-create var1 * Aos
^done,name="var1",numchild="2",value="[2]",type="bar.array_of_string",thread-id="1",has_more="0"

Now print it:

(gdb) -var-list-children 1 var1
^done,numchild="2",children=[child={name="var1.1",exp="1",numchild="1",value="[2] \"ab\"", type="bar.string_access",thread-id="1"},child={name="var1.2",exp="2",numchild="1",value="[2] \"cd\"", type="bar.string_access",thread-id="1"}],has_more="0"

But printed fields "value" are wrong, since it should be:

^done,numchild="2",children=[child={name="var1.1",exp="1",numchild="1",value="0x634018",type="bar.string_access",thread-id="1"},child={name="var1.2",exp="2",numchild="1",value="0x634038",type="bar.string_access",thread-id="1"}],has_more="0"^M

Print each child of var1:

(gdb) -var-evaluate-expression var1.1
^done,value="[2] \"ab\""
(gdb) -var-evaluate-expression var1.2
^done,value="[2] \"cd\""

Whereas it should be

(gdb) -var-evaluate-expression var1.1
^done,value="0x635018"
(gdb) -var-evaluate-expression var1.2
^done,value="0x635038"

This patch fixes this.

gdb/ChangeLog:

        * ada-lang.c (ada_value_subscript): Handle case when parameter is
        an array of access to unconstrained array.

testsuite/ChangeLog

        * gdb.ada/mi_string_access.exp: New testcase.
        * gdb.ada/mi_string_access/bar.adb: New file.
        * gdb.ada/mi_string_access/pck.adb: New file.
        * gdb.ada/mi_string_access/pck.asd: New file.

Tested on x86_64-linux.
---
 gdb/ChangeLog                                  |  5 ++
 gdb/ada-lang.c                                 | 24 ++++++++++
 gdb/testsuite/ChangeLog                        |  7 +++
 gdb/testsuite/gdb.ada/mi_string_access.exp     | 64 ++++++++++++++++++++++++++
 gdb/testsuite/gdb.ada/mi_string_access/bar.adb | 24 ++++++++++
 gdb/testsuite/gdb.ada/mi_string_access/pck.adb | 21 +++++++++
 gdb/testsuite/gdb.ada/mi_string_access/pck.ads | 19 ++++++++
 7 files changed, 164 insertions(+)
 create mode 100644 gdb/testsuite/gdb.ada/mi_string_access.exp
 create mode 100644 gdb/testsuite/gdb.ada/mi_string_access/bar.adb
 create mode 100644 gdb/testsuite/gdb.ada/mi_string_access/pck.adb
 create mode 100644 gdb/testsuite/gdb.ada/mi_string_access/pck.ads

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 5401864..40b7978 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,10 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* ada-lang.c (ada_value_subscript): Handle case when parameter is
+	an array of access to unconstrained array.
+
+2018-09-10  Xavier Roirand  <roirand@adacore.com>
+
 	* ada-lang.c (ada_is_access_to_unconstrained_array): New function.
 	(ada_check_typedef): Use it.
 
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 83421ac..5f39def 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -2861,10 +2861,34 @@ ada_value_subscript (struct value *arr, int arity, struct value **ind)
 
   for (k = 0; k < arity; k += 1)
     {
+      struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
+
       if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
         error (_("too many subscripts (%d expected)"), k);
+
       elt = value_subscript (elt, pos_atr (ind[k]));
+
+      if (ada_is_access_to_unconstrained_array (saved_elt_type)
+	  && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
+	{
+	  /* The element is a typedef to an unconstrained array,
+	     except that the value_subscript call stripped the
+	     typedef layer.  The typedef layer is GNAT's way to
+	     specify that the element is, at the source level, an
+	     access to the unconstrained array, rather than the
+	     unconstrained array.  So, we need to restore that
+	     typedef layer, which we can do by forcing the element's
+	     type back to its original type. Otherwise, the returned
+	     value is going to be printed as the array, rather
+	     than as an access.  Another symptom of the same issue
+	     would be that an expression trying to dereference the
+	     element would also be improperly rejected.  */
+	  deprecated_set_value_type (elt, saved_elt_type);
+	}
+
+      elt_type = ada_check_typedef (value_type (elt));
     }
+
   return elt;
 }
 
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 3911b8c..8c47e86 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,5 +1,12 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* gdb.ada/mi_string_access.exp: New testcase.
+	* gdb.ada/mi_string_access/bar.adb: New file.
+	* gdb.ada/mi_string_access/pck.adb: New file.
+	* gdb.ada/mi_string_access/pck.asd: New file.
+
+2018-09-10  Xavier Roirand  <roirand@adacore.com>
+
 	* gdb.ada/mi_var_union.exp: New testcase.
 	* gdb.ada/mi_var_union/bar.adb: New file.
 	* gdb.ada/mi_var_union/pck.adb: New file.
diff --git a/gdb/testsuite/gdb.ada/mi_string_access.exp b/gdb/testsuite/gdb.ada/mi_string_access.exp
new file mode 100644
index 0000000..8ecf907
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_string_access.exp
@@ -0,0 +1,64 @@
+# Copyright 2018 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"
+
+standard_ada_testfile bar
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug]] != "" } {
+  return -1
+}
+
+load_lib mi-support.exp
+set MIFLAGS "-i=mi"
+
+gdb_exit
+if [mi_gdb_start] {
+    continue
+}
+
+mi_delete_breakpoints
+mi_gdb_reinitialize_dir $srcdir/$subdir
+mi_gdb_load ${binfile}
+
+if ![mi_run_to_main] then {
+   fail "Cannot run to main, testcase aborted"
+   return 0
+}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/bar.adb]
+mi_continue_to_line \
+    "bar.adb:$bp_location" \
+    "stop at start of main Ada procedure"
+
+mi_gdb_test "-var-create var1 * Aos" \
+    "\\^done,name=\"var1\",numchild=\"2\",.*" \
+    "Create var1 varobj"
+
+mi_gdb_test "-var-list-children 1 var1" \
+    "\\^done,numchild=\"2\",children=\\\[child={name=\"var1.1\",exp=\"1\",numchild=\"1\",value=\"$hex\",type=\"bar.string_access\",thread-id=\"$decimal\"},child={name=\"var1.2\",exp=\"2\",numchild=\"1\",value=\"$hex\",type=\"bar.string_access\",thread-id=\"$decimal\"}\\\],has_more=\"0\"" \
+    "list var1's children"
+
+mi_gdb_test "-var-evaluate-expression var1" \
+    "\\^done,value=\"\\\[2\\\]\"" \
+    "Print var1"
+
+mi_gdb_test "-var-evaluate-expression var1.1" \
+    "\\^done,value=\"$hex\"" \
+    "Print var1 first child"
+
+mi_gdb_test "-var-evaluate-expression var1.2" \
+    "\\^done,value=\"$hex\"" \
+    "Print var1 second child"
diff --git a/gdb/testsuite/gdb.ada/mi_string_access/bar.adb b/gdb/testsuite/gdb.ada/mi_string_access/bar.adb
new file mode 100644
index 0000000..544376c
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_string_access/bar.adb
@@ -0,0 +1,24 @@
+--  Copyright 2018 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 Bar is
+   type String_Access is access String;
+   type Array_Of_String is array (1 .. 2) of String_Access;
+   Aos : Array_Of_String := (new String'("ab"), new String'("cd"));
+begin
+   Do_Nothing (Aos'Address);  -- STOP
+end Bar;
diff --git a/gdb/testsuite/gdb.ada/mi_string_access/pck.adb b/gdb/testsuite/gdb.ada/mi_string_access/pck.adb
new file mode 100644
index 0000000..dcfb306
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_string_access/pck.adb
@@ -0,0 +1,21 @@
+--  Copyright 2018 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/mi_string_access/pck.ads b/gdb/testsuite/gdb.ada/mi_string_access/pck.ads
new file mode 100644
index 0000000..33e369e
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_string_access/pck.ads
@@ -0,0 +1,19 @@
+--  Copyright 2018 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
+   procedure Do_Nothing (A : System.Address);
+end Pck;
-- 
2.1.4