[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.
This commit is contained in:
Jerome Guitton 2014-02-12 12:08:23 +01:00 committed by Joel Brobecker
parent 7d03f2eb64
commit 5ec18f2b48
7 changed files with 162 additions and 10 deletions

View File

@ -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

View File

@ -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 =

View File

@ -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.

View File

@ -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"

View File

@ -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;

View File

@ -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;

View File

@ -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;