[Ada] Full view of tagged type with ptype

When evaluating an expression, if it is of a tagged type, GDB reads
the tag in memory and deduces the full view. At parsing time, however,
this operation is done only in the case of OP_VAR_VALUE. ptype does
not go through a full evaluation of expressions so it may return some
odd results:

 (gdb) print c.menu_name
 $1 = 0x0
 (gdb) ptype $
 type = system.strings.string_access
 (gdb) ptype c.menu_name
 type = <void>

This change removes this peculiarity by extending the tag resolution
to UNOP_IND and STRUCTOP_STRUCT. As in the case of OP_VAR_VALUE, this
implies switching from EVAL_AVOID_SIDE_EFFECTS to EVAL_NORMAL when a
tagged type is dereferenced.

gdb/
	* ada-lang.c (ada_evaluate_subexp): Resolve tagged types to
	full view in the case of UNOP_IND and STRUCTOP_STRUCT.

gdb/testsuite/

	* gdb.ada/tagged_access: New testcase.

7 files changed, 162 insertions, 10 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 60087c7..73ab666 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,8 @@
+2014-03-10  Jerome Guitton  <guitton@adacore.com>
+
+	* ada-lang.c (ada_evaluate_subexp): Resolve tagged types to
+	full view in the case of UNOP_IND and STRUCTOP_STRUCT.
+
 2014-03-10  Hui Zhu  <hui@codesourcery.com>
 
 	* target.h (target_insert_breakpoint): Remove "hardware" from its
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index 92f437f..e36a64b 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -9878,6 +9878,7 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
   enum exp_opcode op;
   int tem;
   int pc;
+  int preeval_pos;
   struct value *arg1 = NULL, *arg2 = NULL, *arg3;
   struct type *type;
   int nargs, oplen;
@@ -10713,6 +10714,7 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
         return arg1;
 
     case UNOP_IND:
+      preeval_pos = *pos;
       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
       if (noside == EVAL_SKIP)
         goto nosideret;
@@ -10733,10 +10735,26 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
                    /* In C you can dereference an array to get the 1st elt.  */
                    || TYPE_CODE (type) == TYPE_CODE_ARRAY)
             {
-              type = to_static_fixed_type
-                (ada_aligned_type
-                 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
-              check_size (type);
+            /* As mentioned in the OP_VAR_VALUE case, tagged types can
+               only be determined by inspecting the object's tag.
+               This means that we need to evaluate completely the
+               expression in order to get its type.  */
+
+	      if ((TYPE_CODE(type) == TYPE_CODE_REF
+		   || TYPE_CODE(type) == TYPE_CODE_PTR)
+		  && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
+		{
+		  arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
+					  EVAL_NORMAL);
+		  type = value_type (ada_value_ind (arg1));
+		}
+	      else
+		{
+		  type = to_static_fixed_type
+		    (ada_aligned_type
+		     (ada_check_typedef (TYPE_TARGET_TYPE (type))));
+		}
+	      check_size (type);
               return value_zero (type, lval_memory);
             }
           else if (TYPE_CODE (type) == TYPE_CODE_INT)
@@ -10780,6 +10798,7 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
     case STRUCTOP_STRUCT:
       tem = longest_to_int (exp->elts[pc + 1].longconst);
       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
+      preeval_pos = *pos;
       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
       if (noside == EVAL_SKIP)
         goto nosideret;
@@ -10792,13 +10811,21 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
               type = ada_lookup_struct_elt_type (type1,
                                                  &exp->elts[pc + 2].string,
                                                  1, 1, NULL);
+
+	      /* If the field is not found, check if it exists in the
+		 extension of this object's type. This means that we
+		 need to evaluate completely the expression.  */
+
               if (type == NULL)
-                /* In this case, we assume that the field COULD exist
-                   in some extension of the type.  Return an object of 
-                   "type" void, which will match any formal 
-                   (see ada_type_match).  */
-                return value_zero (builtin_type (exp->gdbarch)->builtin_void,
-				   lval_memory);
+		{
+		  arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
+					  EVAL_NORMAL);
+		  arg1 = ada_value_struct_elt (arg1,
+					       &exp->elts[pc + 2].string,
+					       0);
+		  arg1 = unwrap_value (arg1);
+		  type = value_type (ada_to_fixed_value (arg1));
+		}
             }
           else
             type =
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 6cbf534..44fb290 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2014-03-10  Joel Brobecker  <brobecker@adacore.com>
+
+	* gdb.ada/tagged_access: New testcase.
+
 2014-03-07  Markus Metzger  <markus.t.metzger@intel.com>
 
 	* gdb.btrace/data.exp: Update expected output.
diff --git a/gdb/testsuite/gdb.ada/tagged_access.exp b/gdb/testsuite/gdb.ada/tagged_access.exp
new file mode 100644
index 0000000..c5832e8
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/tagged_access.exp
@@ -0,0 +1,33 @@
+# Copyright 2014 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 p
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug]] != "" } {
+  return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "BREAK" ${testdir}/p.adb]
+runto "p.adb:$bp_location"
+
+gdb_test "ptype c.all" \
+         " = new pack\\.interactive_command with record\r\n\\s+menu_name: pack\\.string_access;\r\nend record"
+
+gdb_test "ptype c.menu_name" \
+         " = access array \\(<>\\) of character"
diff --git a/gdb/testsuite/gdb.ada/tagged_access/p.adb b/gdb/testsuite/gdb.ada/tagged_access/p.adb
new file mode 100644
index 0000000..b1f4d1f
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/tagged_access/p.adb
@@ -0,0 +1,22 @@
+--  Copyright 2014 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;
+
+procedure P is
+   C : Pack.Interactive_Command_Access := Pack.New_Command;
+begin
+   Pack.Id (C); -- BREAK
+end P;
diff --git a/gdb/testsuite/gdb.ada/tagged_access/pack.adb b/gdb/testsuite/gdb.ada/tagged_access/pack.adb
new file mode 100644
index 0000000..1bf5500
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/tagged_access/pack.adb
@@ -0,0 +1,30 @@
+--  Copyright 2014 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
+
+   Global_Command : aliased My_Command := My_Command'(menu_name => null);
+
+   function New_Command return Interactive_Command_Access is
+   begin
+      return Global_Command'access;
+   end New_Command;
+
+   procedure Id (C : in out Interactive_Command_Access) is
+   begin
+      null;
+   end Id;
+
+end Pack;
diff --git a/gdb/testsuite/gdb.ada/tagged_access/pack.ads b/gdb/testsuite/gdb.ada/tagged_access/pack.ads
new file mode 100644
index 0000000..6074009
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/tagged_access/pack.ads
@@ -0,0 +1,31 @@
+--  Copyright 2014 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 Pack is
+
+   type Interactive_Command is abstract tagged null record;
+   type Interactive_Command_Access is access all Interactive_Command'Class;
+
+   type String_Access is access all String;
+
+   type My_Command is new Interactive_Command with record
+      menu_name : String_Access;
+   end record;
+
+   function New_Command return Interactive_Command_Access;
+
+   procedure Id (C : in out Interactive_Command_Access);
+
+end Pack;