[PATCH 6/6] (Ada) Fix resolving of homonym components in tagged types

[PATCH 6/6] (Ada) Fix resolving of homonym components in tagged types

[Joel Brobecker]

From: Jerome Guitton <guitton@adacore.com>

ada_value_struct_elt is used when displaying a component (say, 'N') of
a record object (say, 'Obj') of type, say, 't1'. Now if Obj is tagged
(Ada parlance: "tagged types" are what other object-oriented languages
call "classes"), then 'N' may not be visible in the current view and
we need to look for it in its actual type. We do that at the same time
as resolving variable-length fields. This would typically be done by
the following call to ada_value_struct_elt, with the last parameter
check_tag set to 1:

      t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
                              address, NULL, 1);

This is the general logic, but recently we introduced a special case
to handle homonyms. Different components may have the same name in a
tagged type.  For instance:

       type Top_T is tagged record
          N : Integer := 1;
       end record;

       type Middle_T is new Top.Top_T with record
          N : Character := 'a';
       end record;

Middle_T extends Top_T and both define a (different) component with
the same name ('N'). In such a case, using the actual type of a
Middle_T object would create a confusion, since we would have two
component 'N' in this actual type.

So, to handle homonyms, we convert t1 to the actual type *if
and only if* N cannot be found in the current view. For example, if Obj
has been created as a Middle_T but is seen as a Top_T'Class at our
point of execution, then "print Obj.N" will display the integer field
defined in Top_T's declaration.

Now, even if we find N in the current view, we still have to get a
fixed type: for instance, the record can be unconstrained and we still
need a fixed type to get the proper offset to each field. That is
to say, in this case:

   type Dyn_Top_T (Disc : Natural) is tagged record
      S : Integer_Array (1 .. Disc) := (others => Disc);
      N : Integer := 1;
   end record;

   type Dyn_Middle_T is new Dyn_Top.Dyn_Top_T with record
      N : Character := 'a';
      U : Integer := 42;
   end record;

If we have an object Obj of type Dyn_Middle_T and we want to display
U, we don't need to build, from its tag, a real type with all its real
fields. In other words, we don't need to add the parent components:
Disc, S, and the integer N. We only need to access U and it is
directly visible in Dyn_Middle_T. So no tag handling. However, we do
need to build a fixed-size type to have the proper offset to U (since
this offset to U depends on the size of Obj.S, which itself is dynamic
and depends on the value of Obj.Disc).

We accidentally lost some of this treatment when we introduced the
resolution of homonyms. This patch re-install this part by uncoupling
the tag resolution from the "fixing" of variable-length components.

This change also slightly simplifies the non-tagged case: in the
non-tagged case, no need to set check_tag to 1, since we already know
that there is no tag.

gdb/ChangeLog:

	* ada-lang.c (ada_value_struct_elt): Call ada_to_fixed_type
	with check_tag to 1 if and only if the type is tagged and the
	component being searched cannot been found in the current
	view. Otherwise, always call ada_to_fixed_type with
	check_tag to 0.

gdb/testsuite/ChangeLog:

	* gdb.ada/same_component_name: Add test for case of tagged record
	with variable-length fields.
---
 gdb/ChangeLog                                     |  8 ++++++++
 gdb/ada-lang.c                                    | 14 +++++++++----
 gdb/testsuite/ChangeLog                           |  5 +++++
 gdb/testsuite/gdb.ada/same_component_name.exp     | 10 +++++++++
 gdb/testsuite/gdb.ada/same_component_name/foo.adb | 11 +++++++---
 gdb/testsuite/gdb.ada/same_component_name/pck.adb | 15 ++++++++++++++
 gdb/testsuite/gdb.ada/same_component_name/pck.ads | 25 +++++++++++++++++++++++
 7 files changed, 81 insertions(+), 7 deletions(-)

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 0c94ad4..392d77a 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,11 @@
+2018-09-10  Jerome Guitton  <guitton@adacore.com>
+
+	* ada-lang.c (ada_value_struct_elt): Call ada_to_fixed_type
+	with check_tag to 1 if and only if the type is tagged and the
+	component being searched cannot been found in the current
+	view. Otherwise, always call ada_to_fixed_type with
+	check_tag to 0.
+
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
 	* ada-lang.c (ada_is_access_to_unconstrained_array): Remove static
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index d151dde..1462271 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -7554,6 +7554,7 @@ ada_value_struct_elt (struct value *arg, const char *name, int no_err)
 {
   struct type *t, *t1;
   struct value *v;
+  int check_tag;
 
   v = NULL;
   t1 = t = ada_check_typedef (value_type (arg));
@@ -7617,12 +7618,17 @@ ada_value_struct_elt (struct value *arg, const char *name, int no_err)
           if (!find_struct_field (name, t1, 0,
                                   &field_type, &byte_offset, &bit_offset,
                                   &bit_size, NULL))
-	    t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
-                                    address, NULL, 1);
+	    check_tag = 1;
+	  else
+	    check_tag = 0;
         }
       else
-        t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
-                                address, NULL, 1);
+	check_tag = 0;
+
+      /* Convert to fixed type in all cases, so that we have proper
+	 offsets to each field in unconstrained record types.  */
+      t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
+			      address, NULL, check_tag);
 
       if (find_struct_field (name, t1, 0,
                              &field_type, &byte_offset, &bit_offset,
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index bad86cf..fc18b22 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-09-10  Jerome Guitton  <guitton@adacore.com>
+
+	* gdb.ada/same_component_name: Add test for case of tagged record
+	with variable-length fields.
+
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
 	* gdb.ada/access_to_unbounded_array.exp: New testcase.
diff --git a/gdb/testsuite/gdb.ada/same_component_name.exp b/gdb/testsuite/gdb.ada/same_component_name.exp
index 9069c2d..34e29c1 100644
--- a/gdb/testsuite/gdb.ada/same_component_name.exp
+++ b/gdb/testsuite/gdb.ada/same_component_name.exp
@@ -26,10 +26,12 @@ clean_restart ${testfile}
 set bp_top_location [gdb_get_line_number "BREAK_TOP" ${testdir}/pck.adb]
 set bp_middle_location [gdb_get_line_number "BREAK_MIDDLE" ${testdir}/pck.adb]
 set bp_bottom_location [gdb_get_line_number "BREAK_BOTTOM" ${testdir}/pck.adb]
+set bp_dyn_middle_location [gdb_get_line_number "BREAK_DYN_MIDDLE" ${testdir}/pck.adb]
 
 gdb_breakpoint "pck.adb:$bp_top_location"
 gdb_breakpoint "pck.adb:$bp_middle_location"
 gdb_breakpoint "pck.adb:$bp_bottom_location"
+gdb_breakpoint "pck.adb:$bp_dyn_middle_location"
 
 gdb_run_cmd
 
@@ -58,3 +60,11 @@ gdb_test "continue" \
 
 gdb_test "print obj.x" " = 6" \
          "Print field existing only in bottom component"
+
+gdb_test "continue" \
+         ".*Breakpoint $decimal, pck.dyn_middle.assign \\(.*\\).*" \
+         "continue to dyn_middle assign breakpoint"
+
+gdb_test "print obj.u" " = 42" \
+         "Print field existing only in dyn_middle component"
+
diff --git a/gdb/testsuite/gdb.ada/same_component_name/foo.adb b/gdb/testsuite/gdb.ada/same_component_name/foo.adb
index 84fe9f5..c7debe1 100644
--- a/gdb/testsuite/gdb.ada/same_component_name/foo.adb
+++ b/gdb/testsuite/gdb.ada/same_component_name/foo.adb
@@ -17,15 +17,20 @@ with Pck;
 use Pck;
 use Pck.Middle;
 use Pck.Top;
+use Pck.Dyn_Middle;
+use Pck.Dyn_Top;
 
 procedure Foo is
-   B : Bottom_T;
-   M : Middle_T;
-
+   B  : Bottom_T;
+   M  : Middle_T;
+   DM : Dyn_Middle_T (24);
 begin
    Assign (Top_T (B), 12);
    Assign (B, 10.0);
 
    Assign (M, 'V');
    Assign (B, 5.0);
+
+   Assign (Dyn_Top_T (DM), 12);
+   Assign (DM, 'V');
 end Foo;
diff --git a/gdb/testsuite/gdb.ada/same_component_name/pck.adb b/gdb/testsuite/gdb.ada/same_component_name/pck.adb
index fd638f7..a0d28b3 100644
--- a/gdb/testsuite/gdb.ada/same_component_name/pck.adb
+++ b/gdb/testsuite/gdb.ada/same_component_name/pck.adb
@@ -39,4 +39,19 @@ package body Pck is
    begin
       null;
    end Do_Nothing;
+
+   package body Dyn_Top is
+      procedure Assign (Obj: in out Dyn_Top_T; TV : Integer) is
+      begin
+         Do_Nothing (Obj'Address); -- BREAK_DYN_TOP
+      end Assign;
+   end Dyn_Top;
+
+   package body Dyn_Middle is
+      procedure Assign (Obj: in out Dyn_Middle_T; MV : Character) is
+      begin
+         Do_Nothing (Obj'Address); -- BREAK_DYN_MIDDLE
+      end Assign;
+   end Dyn_Middle;
+
 end Pck;
diff --git a/gdb/testsuite/gdb.ada/same_component_name/pck.ads b/gdb/testsuite/gdb.ada/same_component_name/pck.ads
index 961aee7..db1554d 100644
--- a/gdb/testsuite/gdb.ada/same_component_name/pck.ads
+++ b/gdb/testsuite/gdb.ada/same_component_name/pck.ads
@@ -48,4 +48,29 @@ package Pck is
 
    procedure Do_Nothing (A : System.Address);
 
+   type Integer_Array is array (Natural range <>) of Integer;
+
+   package Dyn_Top is
+      type Dyn_Top_T (Disc : Natural) is tagged private;
+      type Dyn_Top_A is access Dyn_Top_T'Class;
+      procedure Assign (Obj: in out Dyn_Top_T; TV : Integer);
+   private
+      type Dyn_Top_T (Disc : Natural) is tagged record
+         S : Integer_Array (1 .. Disc) := (others => Disc);
+         N : Integer := 1;
+         A : Integer := 48;
+      end record;
+   end Dyn_Top;
+
+   package Dyn_Middle is
+      type Dyn_Middle_T is new Dyn_Top.Dyn_Top_T with private;
+      type Dyn_Middle_A is access Dyn_Middle_T'Class;
+      procedure Assign (Obj: in out Dyn_Middle_T; MV : Character);
+   private
+      type Dyn_Middle_T is new Dyn_Top.Dyn_Top_T with record
+         N : Character := 'a';
+         U : Integer := 42;
+      end record;
+   end Dyn_Middle;
+
 end Pck;
-- 
2.1.4

[PATCH 5/6] (Ada) Cleanup code by using ada_is_access_to_unconstrained_array call.

[Joel Brobecker]

From: Xavier Roirand <roirand@adacore.com>

This patch just avoids code duplication by using a function we
introduced recently (ada_is_access_to_unconstrained_array).

gdb/ChangeLog:

    * ada-lang.c (ada_is_access_to_unconstrained_array): Remove static
    declaration.
    * ada-lang.h: add ada_is_access_to_unconstrained_array prototype.
    * ada-varobj.c (ada_varobj_get_number_of_children,
    ada_varobj_describe_child, ada_value_is_changeable_p): Cleanup code.

Tested on x86_64-linux.
No new testcase provided, as this is just a refactoring.
---
 gdb/ChangeLog    | 8 ++++++++
 gdb/ada-lang.c   | 2 +-
 gdb/ada-lang.h   | 2 ++
 gdb/ada-varobj.c | 9 +++------
 4 files changed, 14 insertions(+), 7 deletions(-)

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 524d218..0c94ad4 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,13 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* ada-lang.c (ada_is_access_to_unconstrained_array): Remove static
+	declaration.
+	* ada-lang.h: add ada_is_access_to_unconstrained_array prototype.
+	* ada-varobj.c (ada_varobj_get_number_of_children,
+	ada_varobj_describe_child, ada_value_is_changeable_p): Cleanup code.
+
+2018-09-10  Xavier Roirand  <roirand@adacore.com>
+
 	* ada-valprint.c (ada_value_print): Use type instead of
 	enclosing type.
 
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 5f39def..d151dde 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -2834,7 +2834,7 @@ value_assign_to_component (struct value *container, struct value *component,
 
 /* Determine if TYPE is an access to an unconstrained array.  */
 
-static bool
+bool
 ada_is_access_to_unconstrained_array (struct type *type)
 {
   return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
diff --git a/gdb/ada-lang.h b/gdb/ada-lang.h
index 90bfa0a..ee5394c 100644
--- a/gdb/ada-lang.h
+++ b/gdb/ada-lang.h
@@ -194,6 +194,8 @@ extern void ada_printstr (struct ui_file *, struct type *, const gdb_byte *,
 struct value *ada_convert_actual (struct value *actual,
                                   struct type *formal_type0);
 
+extern bool ada_is_access_to_unconstrained_array (struct type *type);
+
 extern struct value *ada_value_subscript (struct value *, int,
                                           struct value **);
 
diff --git a/gdb/ada-varobj.c b/gdb/ada-varobj.c
index 5baefd9..8a01cb9 100644
--- a/gdb/ada-varobj.c
+++ b/gdb/ada-varobj.c
@@ -350,8 +350,7 @@ ada_varobj_get_number_of_children (struct value *parent_value,
   /* A typedef to an array descriptor in fact represents a pointer
      to an unconstrained array.  These types always have one child
      (the unconstrained array).  */
-  if (ada_is_array_descriptor_type (parent_type)
-      && TYPE_CODE (parent_type) == TYPE_CODE_TYPEDEF)
+  if (ada_is_access_to_unconstrained_array (parent_type))
     return 1;
 
   if (TYPE_CODE (parent_type) == TYPE_CODE_ARRAY)
@@ -680,8 +679,7 @@ ada_varobj_describe_child (struct value *parent_value,
   if (child_path_expr)
     *child_path_expr = std::string ();
 
-  if (ada_is_array_descriptor_type (parent_type)
-      && TYPE_CODE (parent_type) == TYPE_CODE_TYPEDEF)
+  if (ada_is_access_to_unconstrained_array (parent_type))
     {
       ada_varobj_describe_ptr_child (parent_value, parent_type,
 				     parent_name, parent_path_expr,
@@ -937,8 +935,7 @@ ada_value_is_changeable_p (const struct varobj *var)
   struct type *type = (var->value != nullptr
 		       ? value_type (var->value.get ()) : var->type);
 
-  if (ada_is_array_descriptor_type (type)
-      && TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
+  if (ada_is_access_to_unconstrained_array (type))
     {
       /* This is in reality a pointer to an unconstrained array.
 	 its value is changeable.  */
-- 
2.1.4

[PATCH 1/6] (Ada) Fix -var-list-children MI command for union type

[Joel Brobecker]

From: Xavier Roirand <roirand@adacore.com>

Using this Ada code:

   type Union_Type (A : Boolean := False) is record
      case A is
         when True  => B : Integer;
         when False => C : Float;
      end case;
   end record;
   pragma Unchecked_Union (Union_Type);
   Ut : Union_Type := (A => True, B => 3);

In GDB/MI mode, once creating a varobj from variable "Ut" as follow:

(gdb) -var-create var1 * ut
^done,name="var1",numchild="2",value="{...}",type="foo.union_type",thread-id="1",has_more="0"

Printing the list of its children displays:

(gdb) -var-list-children 1 var1
^error,msg="Duplicate variable object name"

Whereas it should be

(gdb) -var-list-children 1 var1
^done,numchild="2",children=[child={name="var1.b",exp="b",numchild="0",value="3",type="integer",thread-id="1"},child={name="var1.c",exp="c",numchild="0",value="4.20389539e-45",type="float",thread-id="1"}],has_more="0"

The problem occurs because ada_varobj_describe_struct_child wasn't
handling unions.  This patch fixes this.

gdb/ChangeLog:

        * ada-varobj.c (ada_varobj_describe_struct_child)
        (ada_varobj_describe_child): Handle union case like struct one.

testsuite/ChangeLog

        * 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.
        * gdb.ada/mi_var_union/pck.asd: New file.

Tested on x86_64-linux.
---
 gdb/ChangeLog                              |  5 +++
 gdb/ada-varobj.c                           |  6 ++--
 gdb/testsuite/ChangeLog                    |  7 ++++
 gdb/testsuite/gdb.ada/mi_var_union.exp     | 54 ++++++++++++++++++++++++++++++
 gdb/testsuite/gdb.ada/mi_var_union/bar.adb | 29 ++++++++++++++++
 gdb/testsuite/gdb.ada/mi_var_union/pck.adb | 21 ++++++++++++
 gdb/testsuite/gdb.ada/mi_var_union/pck.ads | 19 +++++++++++
 7 files changed, 139 insertions(+), 2 deletions(-)
 create mode 100644 gdb/testsuite/gdb.ada/mi_var_union.exp
 create mode 100644 gdb/testsuite/gdb.ada/mi_var_union/bar.adb
 create mode 100644 gdb/testsuite/gdb.ada/mi_var_union/pck.adb
 create mode 100644 gdb/testsuite/gdb.ada/mi_var_union/pck.ads

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 7adb11f..ca678dd 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,8 @@
+2018-09-10  Xavier Roirand  <roirand@adacore.com>
+
+	* ada-varobj.c (ada_varobj_describe_struct_child)
+	(ada_varobj_describe_child): Handle union case like struct one.
+
 2018-09-10  Tom Tromey  <tom@tromey.com>
 
 	PR python/18380:
diff --git a/gdb/ada-varobj.c b/gdb/ada-varobj.c
index 6dafe47..5baefd9 100644
--- a/gdb/ada-varobj.c
+++ b/gdb/ada-varobj.c
@@ -419,7 +419,8 @@ ada_varobj_describe_struct_child (struct value *parent_value,
   int fieldno;
   int childno = 0;
 
-  gdb_assert (TYPE_CODE (parent_type) == TYPE_CODE_STRUCT);
+  gdb_assert (TYPE_CODE (parent_type) == TYPE_CODE_STRUCT
+	      || TYPE_CODE (parent_type) == TYPE_CODE_UNION);
 
   for (fieldno = 0; fieldno < TYPE_NFIELDS (parent_type); fieldno++)
     {
@@ -699,7 +700,8 @@ ada_varobj_describe_child (struct value *parent_value,
       return;
     }
 
-  if (TYPE_CODE (parent_type) == TYPE_CODE_STRUCT)
+  if (TYPE_CODE (parent_type) == TYPE_CODE_STRUCT
+      || TYPE_CODE (parent_type) == TYPE_CODE_UNION)
     {
       ada_varobj_describe_struct_child (parent_value, parent_type,
 					parent_name, parent_path_expr,
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index a360c22..3911b8c 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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.
+	* gdb.ada/mi_var_union/pck.asd: New file.
+
 2018-09-08  Tom Tromey  <tom@tromey.com>
 
 	* gdb.python/py-prettyprint.exp: Use with_test_prefix.
diff --git a/gdb/testsuite/gdb.ada/mi_var_union.exp b/gdb/testsuite/gdb.ada/mi_var_union.exp
new file mode 100644
index 0000000..26a7ed0
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_var_union.exp
@@ -0,0 +1,54 @@
+# 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
+}
+
+set float "\\-?((\[0-9\]+(\\.\[0-9\]+)?(e\[-+\]\[0-9\]+)?)|(nan\\($hex\\)))"
+
+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 * Ut" \
+    "\\^done,name=\"var1\",numchild=\"2\",.*" \
+    "Create var1 varobj"
+
+mi_gdb_test "-var-list-children 1 var1" \
+    "\\^done,numchild=\"2\",children=\\\[child={name=\"var1.b\",exp=\"b\",numchild=\"0\",value=\"3\",type=\"integer\",thread-id=\"$decimal\"},child={name=\"var1.c\",exp=\"c\",numchild=\"0\",value=\"$float\",type=\"float\",thread-id=\"$decimal\"}\\\],has_more=\"0\"" \
+    "list var1's children"
diff --git a/gdb/testsuite/gdb.ada/mi_var_union/bar.adb b/gdb/testsuite/gdb.ada/mi_var_union/bar.adb
new file mode 100644
index 0000000..9563f34
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_var_union/bar.adb
@@ -0,0 +1,29 @@
+--  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 Union_Type (A : Boolean := False) is record
+      case A is
+         when True  => B : Integer;
+         when False => C : Float;
+      end case;
+   end record;
+   pragma Unchecked_Union (Union_Type);
+   Ut : Union_Type := (A => True, B => 3);
+begin
+   Do_Nothing (Ut'Address);  -- STOP
+end Bar;
diff --git a/gdb/testsuite/gdb.ada/mi_var_union/pck.adb b/gdb/testsuite/gdb.ada/mi_var_union/pck.adb
new file mode 100644
index 0000000..dcfb306
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_var_union/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_var_union/pck.ads b/gdb/testsuite/gdb.ada/mi_var_union/pck.ads
new file mode 100644
index 0000000..33e369e
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/mi_var_union/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

Various Ada fixes (2018-09-10 edition)

[Joel Brobecker]

Hello,

FYI, I have just pushed the following patches to master; for the most
part, these are patches that AdaCore has had for a while, and I am
contributing them for my coworkers.

  * [PATCH 1/6] (Ada) Fix -var-list-children MI command for union type
  * [PATCH 2/6] (Ada) New function ada_is_access_to_unconstrained_array
  * [PATCH 3/6] (Ada/MI) Fix -var-evaluate-expression for access to
  * [PATCH 4/6] (Ada) Fix printing of access to unconstrained arrays
  * [PATCH 5/6] (Ada) Cleanup code by using
  * [PATCH 6/6] (Ada) Fix resolving of homonym components in tagged types

I re-tested them all on x86_64-linux before pushing.

Thanks,
-- 
Joel

[PATCH 4/6] (Ada) Fix printing of access to unconstrained arrays

[Joel Brobecker]

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

When debugging with GDB, printing each Aos element displays:

    (gdb) print Aos(1)
    $2 = "ab"
    (gdb) print Aos(2)
    $3 = "cd"

Whereas it should display:

    (gdb) print Aos(1)
    $2 = (foo_r118_024.string_access) 0x635018
    (gdb) print Aos(2)
    $3 = (foo_r118_024.string_access) 0x635038

Notice that printing the entire array works:

(gdb) print Aos
$1 = (0x635018, 0x635038)

The problem was located in ada_value_print function and due to the fact
that the value_type used in this function was based on
value_enclosing_type rather than value_type itself.
In our example, the difference between the value_type and the
value_enclosing_type of the value is that the value_type contains an
additional typedef layer which is not present in the value_enclosing_type.
This 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.
Moreover, the value_enclosing_type is not really needed in that case and
the value_type can be used instead in this function, and this patch fixes
this.

gdb/ChangeLog:

    * ada-valprint.c (ada_value_print): Use type instead of
    enclosing type.

testsuite/ChangeLog:

    * gdb.ada/access_to_unbounded_array.exp: New testcase.
    * gdb.ada/access_to_unbounded_array/foo.adb: New file.
    * gdb.ada/access_to_unbounded_array/pack.adb: New file.
    * gdb.ada/access_to_unbounded_array/pack.ads: New file.

Tested: x86_64-linux
---
 gdb/ChangeLog                                      |  5 ++++
 gdb/ada-valprint.c                                 |  2 +-
 gdb/testsuite/ChangeLog                            |  7 +++++
 .../gdb.ada/access_to_unbounded_array.exp          | 30 ++++++++++++++++++++++
 .../gdb.ada/access_to_unbounded_array/foo.adb      | 24 +++++++++++++++++
 .../gdb.ada/access_to_unbounded_array/pack.adb     | 23 +++++++++++++++++
 .../gdb.ada/access_to_unbounded_array/pack.ads     | 19 ++++++++++++++
 7 files changed, 109 insertions(+), 1 deletion(-)
 create mode 100644 gdb/testsuite/gdb.ada/access_to_unbounded_array.exp
 create mode 100644 gdb/testsuite/gdb.ada/access_to_unbounded_array/foo.adb
 create mode 100644 gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.adb
 create mode 100644 gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.ads

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 40b7978..524d218 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,10 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* ada-valprint.c (ada_value_print): Use type instead of
+	enclosing type.
+
+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.
 
diff --git a/gdb/ada-valprint.c b/gdb/ada-valprint.c
index a486919..af289e2 100644
--- a/gdb/ada-valprint.c
+++ b/gdb/ada-valprint.c
@@ -1224,7 +1224,7 @@ ada_value_print (struct value *val0, struct ui_file *stream,
 {
   struct value *val = ada_to_fixed_value (val0);
   CORE_ADDR address = value_address (val);
-  struct type *type = ada_check_typedef (value_enclosing_type (val));
+  struct type *type = ada_check_typedef (value_type (val));
   struct value_print_options opts;
 
   /* If it is a pointer, indicate what it points to.  */
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 8c47e86..bad86cf 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,5 +1,12 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* gdb.ada/access_to_unbounded_array.exp: New testcase.
+	* gdb.ada/access_to_unbounded_array/foo.adb: New file.
+	* gdb.ada/access_to_unbounded_array/pack.adb: New file.
+	* gdb.ada/access_to_unbounded_array/pack.ads: New file.
+
+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.
diff --git a/gdb/testsuite/gdb.ada/access_to_unbounded_array.exp b/gdb/testsuite/gdb.ada/access_to_unbounded_array.exp
new file mode 100644
index 0000000..3a22d32
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/access_to_unbounded_array.exp
@@ -0,0 +1,30 @@
+# 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 foo
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug]] != "" } {
+  return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "BREAK" ${testdir}/foo.adb]
+runto "foo.adb:$bp_location"
+
+gdb_test "print Aos(1)" " = \\(foo.string_access\\) $hex"
+gdb_test "print Aos(2)" " = \\(foo.string_access\\) $hex"
diff --git a/gdb/testsuite/gdb.ada/access_to_unbounded_array/foo.adb b/gdb/testsuite/gdb.ada/access_to_unbounded_array/foo.adb
new file mode 100644
index 0000000..b0804c0
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/access_to_unbounded_array/foo.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 Pack; use Pack;
+
+procedure Foo 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); --  BREAK
+end Foo;
diff --git a/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.adb b/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.adb
new file mode 100644
index 0000000..b42e981
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.adb
@@ -0,0 +1,23 @@
+--  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 Pack is
+
+   procedure Do_Nothing (A : System.Address) is
+   begin
+      null;
+   end Do_Nothing;
+
+end Pack;
diff --git a/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.ads b/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.ads
new file mode 100644
index 0000000..400c623
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/access_to_unbounded_array/pack.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 Pack is
+   procedure Do_Nothing (A : System.Address);
+end Pack;
-- 
2.1.4

[PATCH 2/6] (Ada) New function ada_is_access_to_unconstrained_array

[Joel Brobecker]

From: Xavier Roirand <roirand@adacore.com>

Add a new function to check if a given type is an access to an
unconstrained array. This function contains code that is present only
once in the current sources but will be used in a future patch.

gdb/ChangeLog:

        * ada-lang.c (ada_is_access_to_unconstrained_array): New function.
        (ada_check_typedef): Use it.

Tested on x86_64-linux.
---
 gdb/ChangeLog  |  5 +++++
 gdb/ada-lang.c | 15 ++++++++++++---
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index ca678dd..5401864 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,10 @@
 2018-09-10  Xavier Roirand  <roirand@adacore.com>
 
+	* ada-lang.c (ada_is_access_to_unconstrained_array): New function.
+	(ada_check_typedef): Use it.
+
+2018-09-10  Xavier Roirand  <roirand@adacore.com>
+
 	* ada-varobj.c (ada_varobj_describe_struct_child)
 	(ada_varobj_describe_child): Handle union case like struct one.
 
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index b8a11cd..83421ac 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -2832,6 +2832,15 @@ value_assign_to_component (struct value *container, struct value *component,
 	       value_contents (val), 0, bits, 0);
 }
 
+/* Determine if TYPE is an access to an unconstrained array.  */
+
+static bool
+ada_is_access_to_unconstrained_array (struct type *type)
+{
+  return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
+	  && is_thick_pntr (ada_typedef_target_type (type)));
+}
+
 /* The value of the element of array ARR at the ARITY indices given in IND.
    ARR may be either a simple array, GNAT array descriptor, or pointer
    thereto.  */
@@ -9245,13 +9254,13 @@ ada_check_typedef (struct type *type)
   if (type == NULL)
     return NULL;
 
-  /* If our type is a typedef type of a fat pointer, then we're done.
+  /* If our type is an access to an unconstrained array, which is encoded
+     as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
      We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
      what allows us to distinguish between fat pointers that represent
      array types, and fat pointers that represent array access types
      (in both cases, the compiler implements them as fat pointers).  */
-  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
-      && is_thick_pntr (ada_typedef_target_type (type)))
+  if (ada_is_access_to_unconstrained_array (type))
     return type;
 
   type = check_typedef (type);
-- 
2.1.4

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

[Joel Brobecker]

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