From patchwork Mon Sep 10 15:42:08 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Joel Brobecker X-Patchwork-Id: 29293 Received: (qmail 86945 invoked by alias); 10 Sep 2018 15:42:32 -0000 Mailing-List: contact gdb-patches-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner@sourceware.org Delivered-To: mailing list gdb-patches@sourceware.org Received: (qmail 86822 invoked by uid 89); 10 Sep 2018 15:42:31 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-26.1 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=disc X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 10 Sep 2018 15:42:28 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id E9D95116263; Mon, 10 Sep 2018 11:42:26 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id Hg5uyOJIYOv8; Mon, 10 Sep 2018 11:42:26 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id D98841161AE; Mon, 10 Sep 2018 11:42:26 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4233) id D876E55F; Mon, 10 Sep 2018 11:42:26 -0400 (EDT) From: Joel Brobecker To: gdb-patches@sourceware.org Cc: Jerome Guitton Subject: [PATCH 6/6] (Ada) Fix resolving of homonym components in tagged types Date: Mon, 10 Sep 2018 11:42:08 -0400 Message-Id: <1536594128-6487-7-git-send-email-brobecker@adacore.com> In-Reply-To: <1536594128-6487-1-git-send-email-brobecker@adacore.com> References: <1536594128-6487-1-git-send-email-brobecker@adacore.com> From: Jerome Guitton 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 + + * 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 * 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 + + * gdb.ada/same_component_name: Add test for case of tagged record + with variable-length fields. + 2018-09-10 Xavier Roirand * 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;