[Ada] ACATS 4.1K - C452003

Message ID 20200707092736.GA41651@adacore.com
State New
Headers show
Series
  • [Ada] ACATS 4.1K - C452003
Related show

Commit Message

Pierre-Marie de Rodat July 7, 2020, 9:27 a.m.
This test generates an assertion failure when compiling
c452003_root-child.adb and shows that we are missing a null check in
membership tests.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* exp_ch4.adb (Tagged_Membership): Generate a call to
	CW_Membership instead of using Build_CW_Membership.
	(Expand_N_In): Remove wrong handling of null access types and
	corresponding comment.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Generate a
	call to CW_Membership instead of using Build_CW_Membership.
	* rtsfind.ads: Add CW_Membership.
	* exp_atag.ads, exp_atag.adb (Build_CW_Membership): Removed.
	* einfo.ads: Fix typo.
	* libgnat/a-tags.ads, libgnat/a-tags.adb (CW_Membership): Moved
	back to spec.

Patch

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -591,7 +591,7 @@  package Einfo is
 --       never have a null value. Set for constant access values initialized to
 --       a non-null value. This is also set for all access parameters in Ada 83
 --       and Ada 95 modes, and for access parameters that explicitly exclude
---       exclude null in Ada 2005 mode.
+--       null in Ada 2005 mode.
 --
 --       This is used to avoid unnecessary resetting of the Is_Known_Non_Null
 --       flag for such entities. In Ada 2005 mode, this is also used when


diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -27,7 +27,6 @@  with Atree;    use Atree;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Exp_Disp; use Exp_Disp;
-with Exp_Util; use Exp_Util;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
@@ -159,118 +158,6 @@  package body Exp_Atag is
               Make_Simple_Return_Statement (Loc))));
    end Build_Common_Dispatching_Select_Statements;
 
-   -------------------------
-   -- Build_CW_Membership --
-   -------------------------
-
-   procedure Build_CW_Membership
-     (Loc          : Source_Ptr;
-      Obj_Tag_Node : in out Node_Id;
-      Typ_Tag_Node : Node_Id;
-      Related_Nod  : Node_Id;
-      New_Node     : out Node_Id)
-   is
-      Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);
-      Obj_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
-      Typ_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
-      Index    : constant Entity_Id := Make_Temporary (Loc, 'D');
-
-   begin
-      --  Generate:
-
-      --    Tag_Addr : constant Tag := Address!(Obj_Tag);
-      --    Obj_TSD  : constant Type_Specific_Data_Ptr
-      --                          := Build_TSD (Tag_Addr);
-      --    Typ_TSD  : constant Type_Specific_Data_Ptr
-      --                          := Build_TSD (Address!(Typ_Tag));
-      --    Index    : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
-      --    Index >= 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
-
-      Insert_Action (Related_Nod,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Tag_Addr,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (RTE (RE_Address), Loc),
-          Expression          => Unchecked_Convert_To
-                                   (RTE (RE_Address), Obj_Tag_Node)));
-
-      --  Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
-      --  update it.
-
-      Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
-
-      Insert_Action (Related_Nod,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Obj_TSD,
-          Constant_Present    => True,
-          Object_Definition   =>
-            New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
-          Expression          =>
-            Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))),
-        Suppress => All_Checks);
-
-      Insert_Action (Related_Nod,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Typ_TSD,
-          Constant_Present    => True,
-          Object_Definition   =>
-            New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc),
-          Expression          =>
-            Build_TSD (Loc,
-              Unchecked_Convert_To (RTE (RE_Address), Typ_Tag_Node))),
-        Suppress => All_Checks);
-
-      Insert_Action (Related_Nod,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Index,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
-          Expression =>
-            Make_Op_Subtract (Loc,
-              Left_Opnd =>
-                Make_Selected_Component (Loc,
-                  Prefix        =>
-                    Make_Explicit_Dereference (Loc,
-                      New_Occurrence_Of (Obj_TSD, Loc)),
-                  Selector_Name =>
-                     New_Occurrence_Of
-                       (RTE_Record_Component (RE_Idepth), Loc)),
-
-               Right_Opnd =>
-                 Make_Selected_Component (Loc,
-                   Prefix        =>
-                     Make_Explicit_Dereference (Loc,
-                       New_Occurrence_Of (Typ_TSD, Loc)),
-                   Selector_Name =>
-                     New_Occurrence_Of
-                       (RTE_Record_Component (RE_Idepth), Loc)))),
-        Suppress => All_Checks);
-
-      New_Node :=
-        Make_And_Then (Loc,
-          Left_Opnd =>
-            Make_Op_Ge (Loc,
-              Left_Opnd  => New_Occurrence_Of (Index, Loc),
-              Right_Opnd => Build_Val (Loc, Uint_0)),
-
-          Right_Opnd =>
-            Make_Op_Eq (Loc,
-              Left_Opnd =>
-                Make_Indexed_Component (Loc,
-                  Prefix      =>
-                    Make_Selected_Component (Loc,
-                      Prefix        =>
-                        Make_Explicit_Dereference (Loc,
-                          New_Occurrence_Of (Obj_TSD, Loc)),
-                      Selector_Name =>
-                        New_Occurrence_Of
-                          (RTE_Record_Component (RE_Tags_Table), Loc)),
-                  Expressions =>
-                    New_List (New_Occurrence_Of (Index, Loc))),
-
-              Right_Opnd => Typ_Tag_Node));
-   end Build_CW_Membership;
-
    --------------
    -- Build_DT --
    --------------


diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -41,24 +41,6 @@  package Exp_Atag is
    --  timed, asynchronous, and conditional select and append them to Stmts.
    --  Typ is the tagged type used for dispatching calls.
 
-   procedure Build_CW_Membership
-     (Loc          : Source_Ptr;
-      Obj_Tag_Node : in out Node_Id;
-      Typ_Tag_Node : Node_Id;
-      Related_Nod  : Node_Id;
-      New_Node     : out Node_Id);
-   --  Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-   --  has a table of ancestors and its inheritance level (Idepth). Obj is in
-   --  Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-   --  Obj'Tag. Knowing the level of inheritance of both types, this can be
-   --  computed in constant time by the formula:
-   --
-   --   Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth;
-   --   Index >= 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag
-   --
-   --  Related_Nod is the node where the implicit declaration of variable Index
-   --  is inserted. Obj_Tag_Node is relocated.
-
    function Build_Get_Access_Level
      (Loc      : Source_Ptr;
       Tag_Node : Node_Id) return Node_Id;


diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6827,18 +6827,7 @@  package body Exp_Ch4 is
                      --  If the designated type is tagged, do tagged membership
                      --  operation.
 
-                     --  *** NOTE: we have to check not null before doing the
-                     --  tagged membership test (but maybe that can be done
-                     --  inside Tagged_Membership?).
-
                      if Is_Tagged_Type (Typ) then
-                        Rewrite (N,
-                          Make_And_Then (Loc,
-                            Left_Opnd  => Relocate_Node (N),
-                            Right_Opnd =>
-                              Make_Op_Ne (Loc,
-                                Left_Opnd  => Obj,
-                                Right_Opnd => Make_Null (Loc))));
 
                         --  No expansion will be performed for VM targets, as
                         --  the VM back ends will handle the membership tests
@@ -14969,6 +14958,9 @@  package body Exp_Ch4 is
    --  usually implemented by looking in the ancestor tables contained in the
    --  dispatch table pointed by Left_Expr.Tag for Typ'Tag
 
+   --  In both cases if Left_Expr is an access type, we first check whether it
+   --  is null.
+
    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
    --  function IW_Membership which is usually implemented by looking in the
    --  table of abstract interface types plus the ancestor table contained in
@@ -14983,19 +14975,17 @@  package body Exp_Ch4 is
       Right : constant Node_Id    := Right_Opnd (N);
       Loc   : constant Source_Ptr := Sloc (N);
 
-      Full_R_Typ : Entity_Id;
-      Left_Type  : Entity_Id;
-      New_Node   : Node_Id;
-      Right_Type : Entity_Id;
-      Obj_Tag    : Node_Id;
+      --  Handle entities from the limited view
 
-   begin
-      SCIL_Node := Empty;
+      Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
 
-      --  Handle entities from the limited view
+      Full_R_Typ   : Entity_Id;
+      Left_Type    : Entity_Id := Available_View (Etype (Left));
+      Right_Type   : Entity_Id := Orig_Right_Type;
+      Obj_Tag      : Node_Id;
 
-      Left_Type  := Available_View (Etype (Left));
-      Right_Type := Available_View (Etype (Right));
+   begin
+      SCIL_Node := Empty;
 
       --  In the case where the type is an access type, the test is applied
       --  using the designated types (needed in Ada 2012 for implicit anonymous
@@ -15069,7 +15059,7 @@  package body Exp_Ch4 is
            or else Is_Interface (Left_Type)
          then
             --  Issue error if IW_Membership operation not available in a
-            --  configurable run time setting.
+            --  configurable run-time setting.
 
             if not RTE_Available (RE_IW_Membership) then
                Error_Msg_CRT
@@ -15092,25 +15082,32 @@  package body Exp_Ch4 is
          --  Ada 95: Normal case
 
          else
-            Build_CW_Membership (Loc,
-              Obj_Tag_Node => Obj_Tag,
-              Typ_Tag_Node =>
-                 New_Occurrence_Of (
-                   Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),  Loc),
-              Related_Nod => N,
-              New_Node    => New_Node);
+            --  Issue error if CW_Membership operation not available in a
+            --  configurable run-time setting.
+
+            if not RTE_Available (RE_CW_Membership) then
+               Error_Msg_CRT
+                 ("dynamic membership test on tagged types", N);
+               Result := Empty;
+               return;
+            end if;
+
+            Result :=
+              Make_Function_Call (Loc,
+                 Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+                 Parameter_Associations => New_List (
+                   Obj_Tag,
+                   New_Occurrence_Of (
+                     Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
+                     Loc)));
 
             --  Generate the SCIL node for this class-wide membership test.
-            --  Done here because the previous call to Build_CW_Membership
-            --  relocates Obj_Tag.
 
             if Generate_SCIL then
                SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
                Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
                Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
             end if;
-
-            Result := New_Node;
          end if;
 
       --  Right_Type is not a class-wide type
@@ -15130,6 +15127,29 @@  package body Exp_Ch4 is
                     (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
          end if;
       end if;
+
+      --  if Left is an access object then generate test of the form:
+      --    * if Right_Type excludes null: Left /= null and then ...
+      --    * if Right_Type includes null: Left = null or else ...
+
+      if Is_Access_Type (Orig_Right_Type) then
+         if Can_Never_Be_Null (Orig_Right_Type) then
+            Result := Make_And_Then (Loc,
+              Left_Opnd  =>
+                Make_Op_Ne (Loc,
+                  Left_Opnd  => Left,
+                  Right_Opnd => Make_Null (Loc)),
+              Right_Opnd => Result);
+
+         else
+            Result := Make_Or_Else (Loc,
+              Left_Opnd  =>
+                Make_Op_Eq (Loc,
+                  Left_Opnd  => Left,
+                  Right_Opnd => Make_Null (Loc)),
+              Right_Opnd => Result);
+         end if;
+      end if;
    end Tagged_Membership;
 
    ------------------------------


diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -430,28 +430,21 @@  package body Exp_Intr is
       --  the tag in the table of ancestor tags.
 
       elsif not Is_Interface (Result_Typ) then
-         declare
-            Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
-            CW_Test_Node : Node_Id;
-
-         begin
-            Build_CW_Membership (Loc,
-              Obj_Tag_Node => Obj_Tag_Node,
-              Typ_Tag_Node =>
-                New_Occurrence_Of (
-                   Node (First_Elmt (Access_Disp_Table (
-                                       Root_Type (Result_Typ)))), Loc),
-              Related_Nod => N,
-              New_Node    => CW_Test_Node);
-
-            Insert_Action (N,
-              Make_Implicit_If_Statement (N,
-                Condition =>
-                  Make_Op_Not (Loc, CW_Test_Node),
-                Then_Statements =>
-                  New_List (Make_Raise_Statement (Loc,
-                              New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
-         end;
+         Insert_Action (N,
+           Make_Implicit_If_Statement (N,
+             Condition =>
+               Make_Op_Not (Loc,
+                 Make_Function_Call (Loc,
+                    Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
+                    Parameter_Associations => New_List (
+                      New_Copy_Tree (Tag_Arg),
+                      New_Occurrence_Of (
+                        Node (First_Elmt (Access_Disp_Table (
+                                            Root_Type (Result_Typ)))), Loc)))),
+             Then_Statements =>
+               New_List (
+                 Make_Raise_Statement (Loc,
+                   Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
 
       --  Call IW_Membership test if the Result_Type is an abstract interface
       --  to look for the tag in the table of interface tags.


diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb
--- a/gcc/ada/libgnat/a-tags.adb
+++ b/gcc/ada/libgnat/a-tags.adb
@@ -49,10 +49,6 @@  package body Ada.Tags is
    -- Local Subprograms --
    -----------------------
 
-   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-   --  Given the tag of an object and the tag associated to a type, return
-   --  true if Obj is in Typ'Class.
-
    function Get_External_Tag (T : Tag) return System.Address;
    --  Returns address of a null terminated string containing the external name
 
@@ -82,7 +78,6 @@  package body Ada.Tags is
    --  Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the
    --  address of the record containing the Select Specific Data in T's TSD.
 
-   pragma Inline_Always (CW_Membership);
    pragma Inline_Always (Get_External_Tag);
    pragma Inline_Always (Is_Primary_DT);
    pragma Inline_Always (OSD);


diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads
--- a/gcc/ada/libgnat/a-tags.ads
+++ b/gcc/ada/libgnat/a-tags.ads
@@ -501,6 +501,10 @@  private
    --  dispatch table, return the tagged kind of a type in the context of
    --  concurrency and limitedness.
 
+   function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
+   --  Given the tag of an object and the tag associated to a type, return
+   --  true if Obj is in Typ'Class.
+
    function IW_Membership (This : System.Address; T : Tag) return Boolean;
    --  Ada 2005 (AI-251): General routine that checks if a given object
    --  implements a tagged type. Its common usage is to check if Obj is in


diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -512,6 +512,7 @@  package Rtsfind is
      RE_Check_Interface_Conversion,      -- Ada.Tags
      RE_Check_TSD,                       -- Ada.Tags
      RE_Cstring_Ptr,                     -- Ada.Tags
+     RE_CW_Membership,                   -- Ada.Tags
      RE_Descendant_Tag,                  -- Ada.Tags
      RE_Dispatch_Table,                  -- Ada.Tags
      RE_Dispatch_Table_Wrapper,          -- Ada.Tags
@@ -1798,6 +1799,7 @@  package Rtsfind is
      RE_Check_Interface_Conversion       => Ada_Tags,
      RE_Check_TSD                        => Ada_Tags,
      RE_Cstring_Ptr                      => Ada_Tags,
+     RE_CW_Membership                    => Ada_Tags,
      RE_Descendant_Tag                   => Ada_Tags,
      RE_Dispatch_Table                   => Ada_Tags,
      RE_Dispatch_Table_Wrapper           => Ada_Tags,