2014-05-07 Richard Biener <rguenther@suse.de>

[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch9.adb

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 1909d55..a827284 100644 (file)
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -8878,7 +8878,8 @@ package body Exp_Ch9 is
    --    Target.Primitive (Param1, ..., ParamN);
 
    --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
-   --  marked by pragma Implemented (XXX, By_Any) or not marked at all.
+   --  marked by pragma Implemented (XXX, By_Any | Optional) or not marked
+   --  at all.
 
    --    declare
    --       S : constant Offset_Index :=
@@ -8923,9 +8924,9 @@ package body Exp_Ch9 is
       function Build_Dispatching_Requeue_To_Any return Node_Id;
       --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
       --  the form Concval.Ename. Ename is either marked by pragma Implemented
-      --  (XXX, By_Any) or not marked at all. Create a block which determines
-      --  at runtime whether Ename denotes an entry or a procedure and perform
-      --  the appropriate kind of dispatching select.
+      --  (XXX, By_Any | Optional) or not marked at all. Create a block which
+      --  determines at runtime whether Ename denotes an entry or a procedure
+      --  and perform the appropriate kind of dispatching select.
 
       function Build_Normal_Requeue return Node_Id;
       --  N denotes a non-dispatching requeue statement to either a task or a
@@ -9021,42 +9022,68 @@ package body Exp_Ch9 is
          --  Process the entry wrapper's position in the primary dispatch
          --  table parameter. Generate:
 
-         --    Ada.Tags.Get_Offset_Index
-         --      (Ada.Tags.Tag (Concval),
-         --       <interface dispatch table position of Ename>)
+         --    Ada.Tags.Get_Entry_Index
+         --      (T        => To_Tag_Ptr (Obj'Address).all,
+         --       Position =>
+         --         Ada.Tags.Get_Offset_Index
+         --           (Ada.Tags.Tag (Concval),
+         --            <interface dispatch table position of Ename>));
+
+         --  Note that Obj'Address is recursively expanded into a call to
+         --  Base_Address (Obj).
 
          if Tagged_Type_Expansion then
             Prepend_To (Params,
               Make_Function_Call (Loc,
-                Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
+                Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
                 Parameter_Associations => New_List (
-                  Unchecked_Convert_To (RTE (RE_Tag), Concval),
-                  Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+
+                  Make_Explicit_Dereference (Loc,
+                    Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                      Make_Attribute_Reference (Loc,
+                        Prefix => New_Copy_Tree (Concval),
+                        Attribute_Name => Name_Address))),
+
+                  Make_Function_Call (Loc,
+                    Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
+                    Parameter_Associations => New_List (
+                      Unchecked_Convert_To (RTE (RE_Tag), Concval),
+                      Make_Integer_Literal (Loc,
+                        DT_Position (Entity (Ename))))))));
 
          --  VM targets
 
          else
             Prepend_To (Params,
               Make_Function_Call (Loc,
-                Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-
+                Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
                 Parameter_Associations => New_List (
 
-                  --  Obj_Typ
-
                   Make_Attribute_Reference (Loc,
                     Prefix         => Concval,
                     Attribute_Name => Name_Tag),
 
-                  --  Tag_Typ
+                  Make_Function_Call (Loc,
+                    Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
 
-                  Make_Attribute_Reference (Loc,
-                    Prefix         => New_Reference_To (Etype (Concval), Loc),
-                    Attribute_Name => Name_Tag),
+                    Parameter_Associations => New_List (
+
+                      --  Obj_Tag
+
+                      Make_Attribute_Reference (Loc,
+                        Prefix => Concval,
+                        Attribute_Name => Name_Tag),
+
+                      --  Tag_Typ
+
+                      Make_Attribute_Reference (Loc,
+                        Prefix => New_Reference_To (Etype (Concval), Loc),
+                        Attribute_Name => Name_Tag),
 
-                  --  Position
+                      --  Position
 
-                  Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+                      Make_Integer_Literal (Loc,
+                        DT_Position (Entity (Ename))))))));
          end if;
 
          --  Specific actuals for protected to XXX requeue
@@ -9445,9 +9472,10 @@ package body Exp_Ch9 is
                Analyze (N);
 
             --  The procedure_or_entry_NAME's implementation kind is either
-            --  By_Any or pragma Implemented was not applied at all. In this
-            --  case a runtime test determines whether Ename denotes an entry
-            --  or a protected procedure and performs the appropriate call.
+            --  By_Any, Optional, or pragma Implemented was not applied at all.
+            --  In this case a runtime test determines whether Ename denotes an
+            --  entry or a protected procedure and performs the appropriate
+            --  call.
 
             else
                Rewrite (N, Build_Dispatching_Requeue_To_Any);