--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/exp_sel.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,263 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              E X P _ S E L                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Einfo;   use Einfo;
+with Nlists;  use Nlists;
+with Nmake;   use Nmake;
+with Opt;     use Opt;
+with Rtsfind; use Rtsfind;
+with Sinfo;   use Sinfo;
+with Snames;  use Snames;
+with Stand;   use Stand;
+with Tbuild;  use Tbuild;
+
+package body Exp_Sel is
+
+   -----------------------
+   -- Build_Abort_Block --
+   -----------------------
+
+   function Build_Abort_Block
+     (Loc         : Source_Ptr;
+      Abr_Blk_Ent : Entity_Id;
+      Cln_Blk_Ent : Entity_Id;
+      Blk         : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Block_Statement (Loc,
+          Identifier   => New_Occurrence_Of (Abr_Blk_Ent, Loc),
+
+          Declarations => No_List,
+
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements =>
+                New_List (
+                  Make_Implicit_Label_Declaration (Loc,
+                    Defining_Identifier => Cln_Blk_Ent,
+                    Label_Construct     => Blk),
+                  Blk),
+
+              Exception_Handlers =>
+                New_List (Build_Abort_Block_Handler (Loc))));
+   end Build_Abort_Block;
+
+   -------------------------------
+   -- Build_Abort_Block_Handler --
+   -------------------------------
+
+   function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
+      Stmt : Node_Id;
+
+   begin
+
+      --  With ZCX exceptions, aborts are not defered in handlers. With SJLJ,
+      --  they are deferred at the beginning of Abort_Signal handlers.
+
+      if ZCX_Exceptions then
+         Stmt := Make_Null_Statement (Loc);
+
+      else
+         Stmt :=
+           Make_Procedure_Call_Statement (Loc,
+             Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc),
+             Parameter_Associations => No_List);
+      end if;
+
+      return Make_Implicit_Exception_Handler (Loc,
+        Exception_Choices =>
+          New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
+        Statements        => New_List (Stmt));
+   end Build_Abort_Block_Handler;
+
+   -------------
+   -- Build_B --
+   -------------
+
+   function Build_B
+     (Loc   : Source_Ptr;
+      Decls : List_Id) return Entity_Id
+   is
+      B : constant Entity_Id := Make_Temporary (Loc, 'B');
+   begin
+      Append_To (Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => B,
+          Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
+          Expression          => New_Occurrence_Of (Standard_False, Loc)));
+      return B;
+   end Build_B;
+
+   -------------
+   -- Build_C --
+   -------------
+
+   function Build_C
+     (Loc   : Source_Ptr;
+      Decls : List_Id) return Entity_Id
+   is
+      C : constant Entity_Id := Make_Temporary (Loc, 'C');
+   begin
+      Append_To (Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => C,
+          Object_Definition   =>
+            New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc)));
+      return C;
+   end Build_C;
+
+   -------------------------
+   -- Build_Cleanup_Block --
+   -------------------------
+
+   function Build_Cleanup_Block
+     (Loc       : Source_Ptr;
+      Blk_Ent   : Entity_Id;
+      Stmts     : List_Id;
+      Clean_Ent : Entity_Id) return Node_Id
+   is
+      Cleanup_Block : constant Node_Id :=
+                        Make_Block_Statement (Loc,
+                          Identifier                 =>
+                            New_Occurrence_Of (Blk_Ent, Loc),
+                          Declarations               => No_List,
+                          Handled_Statement_Sequence =>
+                            Make_Handled_Sequence_Of_Statements (Loc,
+                              Statements => Stmts),
+                          Is_Asynchronous_Call_Block => True);
+
+   begin
+      Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
+
+      return Cleanup_Block;
+   end Build_Cleanup_Block;
+
+   -------------
+   -- Build_K --
+   -------------
+
+   function Build_K
+     (Loc   : Source_Ptr;
+      Decls : List_Id;
+      Obj   : Entity_Id) return Entity_Id
+   is
+      K        : constant Entity_Id := Make_Temporary (Loc, 'K');
+      Tag_Node : Node_Id;
+
+   begin
+      if Tagged_Type_Expansion then
+         Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
+      else
+         Tag_Node :=
+           Make_Attribute_Reference (Loc,
+             Prefix         => Obj,
+             Attribute_Name => Name_Tag);
+      end if;
+
+      Append_To (Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => K,
+          Object_Definition   =>
+            New_Occurrence_Of (RTE (RE_Tagged_Kind), Loc),
+          Expression          =>
+            Make_Function_Call (Loc,
+              Name => New_Occurrence_Of (RTE (RE_Get_Tagged_Kind), Loc),
+              Parameter_Associations => New_List (Tag_Node))));
+      return K;
+   end Build_K;
+
+   -------------
+   -- Build_S --
+   -------------
+
+   function Build_S
+     (Loc   : Source_Ptr;
+      Decls : List_Id) return Entity_Id
+   is
+      S : constant Entity_Id := Make_Temporary (Loc, 'S');
+   begin
+      Append_To (Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => S,
+          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));
+      return S;
+   end Build_S;
+
+   ------------------------
+   -- Build_S_Assignment --
+   ------------------------
+
+   function Build_S_Assignment
+     (Loc      : Source_Ptr;
+      S        : Entity_Id;
+      Obj      : Entity_Id;
+      Call_Ent : Entity_Id) return Node_Id
+   is
+      Typ : constant Entity_Id := Etype (Obj);
+
+   begin
+      if Tagged_Type_Expansion then
+         return
+           Make_Assignment_Statement (Loc,
+             Name       => New_Occurrence_Of (S, Loc),
+             Expression =>
+               Make_Function_Call (Loc,
+                 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
+                 Parameter_Associations => New_List (
+                   Unchecked_Convert_To (RTE (RE_Tag), Obj),
+                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
+
+      --  VM targets
+
+      else
+         return
+           Make_Assignment_Statement (Loc,
+             Name       => New_Occurrence_Of (S, Loc),
+             Expression =>
+               Make_Function_Call (Loc,
+                 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
+
+                 Parameter_Associations => New_List (
+
+                     --  Obj_Typ
+
+                   Make_Attribute_Reference (Loc,
+                     Prefix => Obj,
+                     Attribute_Name => Name_Tag),
+
+                     --  Iface_Typ
+
+                   Make_Attribute_Reference (Loc,
+                     Prefix => New_Occurrence_Of (Typ, Loc),
+                     Attribute_Name => Name_Tag),
+
+                     --  Position
+
+                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
+      end if;
+   end Build_S_Assignment;
+
+end Exp_Sel;