[commit/Ada] fix ptype of class-wide object

[Joel Brobecker]

Hello,

Class-wide objects are objects whose type is not known at compile
time.  To print determine the type of these objects, we need to
read into inferior memory.  This is what we do when we print the
value of any such objects, but we had a bug when printing their
type description:

    (gdb) ptype s
    type = new geo.shape with record
        C110b: array (1 .. -1) of system.storage_elements.storage_element;
    end record

For tagged types, when in EVAL_AVOID_SIDE_EFFECTS mode, we have no choice
but to read the value of our object in order to determine its type.
This is what this patch does.

2008-01-04  Joel Brobecker  <brobecker@adacore.com>

        * ada-lang.c (ada_evaluate_subexp): Evaluate tagged types in
        EVAL_NORMAL mode when noside is EVAL_AVOID_SIDE_EFFECTS.

I also wrote a testcase that exercises tagged types in general.
It tests ptype operations, but also print as well.

2008-01-04  Joel Brobecker  <brobecker@adacore.com>

        * gdb.ada/tagged/pck.ads, gdb.ada/tagged/pck.adb,
        gdb.ada/tagged/foo.adb: New file.
        * gdb.ada/tagged.exp: New testcase.

All tested on x86-linux, no regression. Checked in.

-- 
Joel
-------------- next part --------------
Index: ada-lang.c
===================================================================
--- ada-lang.c	(revision 72)
+++ ada-lang.c	(revision 73)
@@ -9520,6 +9520,15 @@ ada_evaluate_subexp (struct type *expect
 
     case OP_VAR_VALUE:
       *pos -= 1;
+
+      /* Tagged types are a little special in the fact that the real type
+         is dynamic and can only be determined by inspecting the object
+         value.  So even if we're support to do an EVAL_AVOID_SIDE_EFFECTS
+         evaluation, we force an EVAL_NORMAL evaluation for tagged types.  */
+      if (noside == EVAL_AVOID_SIDE_EFFECTS
+          && ada_is_tagged_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol), 1))
+        noside = EVAL_NORMAL;
+
       if (noside == EVAL_SKIP)
         {
           *pos += 4;
-------------- next part --------------
Index: gdb.ada/tagged.exp
===================================================================
--- gdb.ada/tagged.exp	(revision 0)
+++ gdb.ada/tagged.exp	(revision 74)
@@ -0,0 +1,76 @@
+# Copyright 2008 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/>.
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+load_lib "ada.exp"
+
+set testdir "tagged"
+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 [list debug]] != "" } {
+  return -1
+}
+
+# A convenience function that joins all the arguments together,
+# with a regexp that matches zero-or-more end of lines in between
+# each argument.  This function is ideal to write the expected output
+# of a GDB command that generates more than a couple of lines, as
+# this allows us to write each line as a separate string, which is
+# easier to read by a human being.
+
+proc multi_line { args } {
+    return [join $args "\[\r\n\]*"]
+}
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+set bp_location [gdb_get_line_number "START" ${testdir}/foo.adb]
+runto "foo.adb:$bp_location"
+
+# Test printing and type-printing of a tagged type that is not
+# class-wide.
+
+gdb_test "ptype segm" \
+         [multi_line "type = new pck\\.object with record" \
+                     "    width: integer;" \
+                     "end record" ] \
+         "ptype segm"
+
+gdb_test "print segm" \
+         "\\(position => 74, width => 8\\)" \
+         "print segm"
+
+# Now, test printing of an class-wide object.
+
+gdb_test "ptype obj" \
+         [multi_line "type = new pck\\.object with record" \
+                     "    width: integer;" \
+                     "end record" ] \
+         "ptype obj"
+
+gdb_test "print obj" \
+         "\\(position => 74, width => 8\\)" \
+         "print obj"
+
+
Index: gdb.ada/tagged/pck.adb
===================================================================
--- gdb.ada/tagged/pck.adb	(revision 0)
+++ gdb.ada/tagged/pck.adb	(revision 74)
@@ -0,0 +1,25 @@
+--  Copyright 2008 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;
+
+
Index: gdb.ada/tagged/pck.ads
===================================================================
--- gdb.ada/tagged/pck.ads	(revision 0)
+++ gdb.ada/tagged/pck.ads	(revision 74)
@@ -0,0 +1,32 @@
+--  Copyright 2008 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
+
+   type Object is tagged record
+      Position : Integer;
+   end record;
+
+   type Segment is new Object with record
+      Width : Integer;
+   end record;
+
+   procedure Do_Nothing (A : System.Address);
+
+end Pck;
+
+
Index: gdb.ada/tagged/foo.adb
===================================================================
--- gdb.ada/tagged/foo.adb	(revision 0)
+++ gdb.ada/tagged/foo.adb	(revision 74)
@@ -0,0 +1,24 @@
+--  Copyright 2008 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
+   Segm : Segment := (Position => 74, Width => 8);
+   Obj : Object'Class := Segm;
+begin
+   Do_Nothing (Segm'Address);  -- START
+   Do_Nothing (Obj'Address);
+end Foo;