[commit/ada] Add support for Ada interface types
Joel Brobecker
brobecker@adacore.com
Tue Jan 1 07:30:00 GMT 2008
Hello,
Ada 2005 introduces the concept of "interface" types, a-la Java.
Internally, the compiler added an extra hidden field inside the
object structure which should not be displayed when printing the
value of an object of that type. The attached patch teaches the
debugger to ignore the field that points the the interface dispatch
table.
2008-01-01 Joel Brobecker <brobecker@adacore.com>
Implement support for Ada interface types.
* ada-lang.c (ada_is_dispatch_table_ptr_type): New function.
(ada_is_ignored_field): Ignore fields that are a dispatch table
of a tagged type.
I also added a testcase for this new feature:
2008-01-01 Joel Brobecker <brobecker@adacore.com>
* gdb.ada/interface/types.ads, gdb.ada/interface/types.adb,
gdb.ada/interface/foo.adb: New files.
* gdb.ada/interface.exp: New testcase.
Tested on x86-linux, no regression.
All checked in.
--
Joel
-------------- next part --------------
Index: ada-lang.c
===================================================================
--- ada-lang.c (revision 18)
+++ ada-lang.c (working copy)
@@ -5630,6 +5630,24 @@ ada_make_symbol_completion_list (char *t
/* Field Access */
+/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
+ for tagged types. */
+
+static int
+ada_is_dispatch_table_ptr_type (struct type *type)
+{
+ char *name;
+
+ if (TYPE_CODE (type) != TYPE_CODE_PTR)
+ return 0;
+
+ name = TYPE_NAME (TYPE_TARGET_TYPE (type));
+ if (name == NULL)
+ return 0;
+
+ return (strcmp (name, "ada__tags__dispatch_table") == 0);
+}
+
/* True if field number FIELD_NUM in struct or union type TYPE is supposed
to be invisible to users. */
@@ -5638,12 +5656,30 @@ ada_is_ignored_field (struct type *type,
{
if (field_num < 0 || field_num > TYPE_NFIELDS (type))
return 1;
- else
- {
- const char *name = TYPE_FIELD_NAME (type, field_num);
- return (name == NULL
- || (name[0] == '_' && strncmp (name, "_parent", 7) != 0));
- }
+
+ /* Check the name of that field. */
+ {
+ const char *name = TYPE_FIELD_NAME (type, field_num);
+
+ /* Anonymous field names should not be printed.
+ brobecker/2007-02-20: I don't think this can actually happen
+ but we don't want to print the value of annonymous fields anyway. */
+ if (name == NULL)
+ return 1;
+
+ /* A field named "_parent" is internally generated by GNAT for
+ tagged types, and should not be printed either. */
+ if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
+ return 1;
+ }
+
+ /* If this is the dispatch table of a tagged type, then ignore. */
+ if (ada_is_tagged_type (type, 1)
+ && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
+ return 1;
+
+ /* Not a special field, so it should not be ignored. */
+ return 0;
}
/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
-------------- next part --------------
Index: gdb.ada/interface.exp
===================================================================
--- gdb.ada/interface.exp (revision 0)
+++ gdb.ada/interface.exp (revision 21)
@@ -0,0 +1,48 @@
+# 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 "interface"
+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 additional_flags=-gnat05 ]] != "" } {
+ return -1
+}
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/foo.adb]
+runto "foo.adb:$bp_location"
+
+gdb_test "print r" \
+ "\\(x => 1, y => 2, w => 3, h => 4\\)" \
+ "print r"
+
+gdb_test "print s" \
+ "\\(x => 1, y => 2, w => 3, h => 4\\)" \
+ "print s"
+
+
Index: gdb.ada/interface/foo.adb
===================================================================
--- gdb.ada/interface/foo.adb (revision 0)
+++ gdb.ada/interface/foo.adb (revision 21)
@@ -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/>.
+
+with Types; use Types;
+
+procedure Foo is
+ R : Rectangle := (1, 2, 3, 4);
+ S : Object'Class := Ident (R);
+begin
+ Do_Nothing (R); -- STOP
+ Do_Nothing (S);
+end Foo;
+
Index: gdb.ada/interface/types.adb
===================================================================
--- gdb.ada/interface/types.adb (revision 0)
+++ gdb.ada/interface/types.adb (revision 21)
@@ -0,0 +1,29 @@
+-- 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 Types is
+
+ function Ident (O : Object'Class) return Object'Class is
+ begin
+ return O;
+ end Ident;
+
+ procedure Do_Nothing (O : in out Object'Class) is
+ begin
+ null;
+ end Do_Nothing;
+
+end Types;
+
Index: gdb.ada/interface/types.ads
===================================================================
--- gdb.ada/interface/types.ads (revision 0)
+++ gdb.ada/interface/types.ads (revision 21)
@@ -0,0 +1,42 @@
+-- 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 Types is
+
+ type Object_Int is interface;
+
+ type Another_Int is interface;
+
+ type Object_Root is abstract tagged record
+ X : Natural;
+ Y : Natural;
+ end record;
+
+ type Object is abstract new Object_Root and Object_Int and Another_Int
+ with null record;
+ function Ident (O : Object'Class) return Object'Class;
+ procedure Do_Nothing (O : in out Object'Class);
+
+ type Rectangle is new Object with record
+ W : Natural;
+ H : Natural;
+ end record;
+
+ type Circle is new Object with record
+ R : Natural;
+ end record;
+
+end Types;
+
More information about the Gdb-patches
mailing list