--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/exp_ch8.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,372 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              E X P _ C H 8                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2017, 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 Atree;    use Atree;
+with Einfo;    use Einfo;
+with Exp_Ch4;  use Exp_Ch4;
+with Exp_Ch6;  use Exp_Ch6;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Nlists;   use Nlists;
+with Opt;      use Opt;
+with Sem;      use Sem;
+with Sem_Ch8;  use Sem_Ch8;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Tbuild;   use Tbuild;
+
+package body Exp_Ch8 is
+
+   ---------------------------------------------
+   -- Expand_N_Exception_Renaming_Declaration --
+   ---------------------------------------------
+
+   procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
+      Decl : Node_Id;
+
+   begin
+      Decl := Debug_Renaming_Declaration (N);
+
+      if Present (Decl) then
+         Insert_Action (N, Decl);
+      end if;
+   end Expand_N_Exception_Renaming_Declaration;
+
+   ------------------------------------------
+   -- Expand_N_Object_Renaming_Declaration --
+   ------------------------------------------
+
+   --  Most object renaming cases can be done by just capturing the address
+   --  of the renamed object. The cases in which this is not true are when
+   --  this address is not computable, since it involves extraction of a
+   --  packed array element, or of a record component to which a component
+   --  clause applies (that can specify an arbitrary bit boundary), or where
+   --  the enclosing record itself has a non-standard representation.
+
+   --  In these two cases, we pre-evaluate the renaming expression, by
+   --  extracting and freezing the values of any subscripts, and then we
+   --  set the flag Is_Renaming_Of_Object which means that any reference
+   --  to the object will be handled by macro substitution in the front
+   --  end, and the back end will know to ignore the renaming declaration.
+
+   --  An additional odd case that requires processing by expansion is
+   --  the renaming of a discriminant of a mutable record type. The object
+   --  is a constant because it renames something that cannot be assigned to,
+   --  but in fact the underlying value can change and must be reevaluated
+   --  at each reference. Gigi does have a notion of a "constant view" of
+   --  an object, and therefore the front-end must perform the expansion.
+   --  For simplicity, and to bypass some obscure code-generation problem,
+   --  we use macro substitution for all renamed discriminants, whether the
+   --  enclosing type is constrained or not.
+
+   --  The other special processing required is for the case of renaming
+   --  of an object of a class wide type, where it is necessary to build
+   --  the appropriate subtype for the renamed object.
+   --  More comments needed for this para ???
+
+   procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
+      Nam  : constant Node_Id := Name (N);
+      Decl : Node_Id;
+      T    : Entity_Id;
+
+      function Evaluation_Required (Nam : Node_Id) return Boolean;
+      --  Determines whether it is necessary to do static name evaluation for
+      --  renaming of Nam. It is considered necessary if evaluating the name
+      --  involves indexing a packed array, or extracting a component of a
+      --  record to which a component clause applies. Note that we are only
+      --  interested in these operations if they occur as part of the name
+      --  itself, subscripts are just values that are computed as part of the
+      --  evaluation, so their form is unimportant.
+      --  In addition, always return True for Modify_Tree_For_C since the
+      --  code generator doesn't know how to handle renamings.
+
+      -------------------------
+      -- Evaluation_Required --
+      -------------------------
+
+      function Evaluation_Required (Nam : Node_Id) return Boolean is
+      begin
+         if Modify_Tree_For_C then
+            return True;
+
+         elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then
+            if Is_Packed (Etype (Prefix (Nam))) then
+               return True;
+            else
+               return Evaluation_Required (Prefix (Nam));
+            end if;
+
+         elsif Nkind (Nam) = N_Selected_Component then
+            declare
+               Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
+
+            begin
+               if Present (Component_Clause (Entity (Selector_Name (Nam))))
+                 or else Has_Non_Standard_Rep (Rec_Type)
+               then
+                  return True;
+
+               elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
+                 and then Is_Record_Type (Rec_Type)
+                 and then not Is_Concurrent_Record_Type (Rec_Type)
+               then
+                  return True;
+
+               else
+                  return Evaluation_Required (Prefix (Nam));
+               end if;
+            end;
+
+         else
+            return False;
+         end if;
+      end Evaluation_Required;
+
+   --  Start of processing for Expand_N_Object_Renaming_Declaration
+
+   begin
+      --  Perform name evaluation if required
+
+      if Evaluation_Required (Nam) then
+         Evaluate_Name (Nam);
+         Set_Is_Renaming_Of_Object (Defining_Identifier (N));
+      end if;
+
+      --  Deal with construction of subtype in class-wide case
+
+      T := Etype (Defining_Identifier (N));
+
+      if Is_Class_Wide_Type (T) then
+         Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
+         Find_Type (Subtype_Mark (N));
+         Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
+
+         --  Freeze the class-wide subtype here to ensure that the subtype
+         --  and equivalent type are frozen before the renaming.
+
+         Freeze_Before (N, Entity (Subtype_Mark (N)));
+      end if;
+
+      --  Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
+      --  place function, then a temporary return object needs to be created
+      --  and access to it must be passed to the function.
+
+      if Is_Build_In_Place_Function_Call (Nam) then
+         Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
+
+      --  Ada 2005 (AI-318-02): Specialization of previous case for renaming
+      --  containing build-in-place function calls whose returned object covers
+      --  interface types.
+
+      elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
+         Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
+      end if;
+
+      --  Create renaming entry for debug information. Mark the entity as
+      --  needing debug info if it comes from sources because the current
+      --  setting in Freeze_Entity occurs too late. ???
+
+      if Comes_From_Source (Defining_Identifier (N)) then
+         Set_Debug_Info_Needed (Defining_Identifier (N));
+      end if;
+
+      Decl := Debug_Renaming_Declaration (N);
+
+      if Present (Decl) then
+         Insert_Action (N, Decl);
+      end if;
+   end Expand_N_Object_Renaming_Declaration;
+
+   -------------------------------------------
+   -- Expand_N_Package_Renaming_Declaration --
+   -------------------------------------------
+
+   procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
+      Decl : Node_Id;
+
+   begin
+      Decl := Debug_Renaming_Declaration (N);
+
+      if Present (Decl) then
+
+         --  If we are in a compilation unit, then this is an outer
+         --  level declaration, and must have a scope of Standard
+
+         if Nkind (Parent (N)) = N_Compilation_Unit then
+            declare
+               Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
+
+            begin
+               Push_Scope (Standard_Standard);
+
+               if No (Actions (Aux)) then
+                  Set_Actions (Aux, New_List (Decl));
+               else
+                  Append (Decl, Actions (Aux));
+               end if;
+
+               Analyze (Decl);
+
+               --  Enter the debug variable in the qualification list, which
+               --  must be done at this point because auxiliary declarations
+               --  occur at the library level and aren't associated with a
+               --  normal scope.
+
+               Qualify_Entity_Names (Decl);
+
+               Pop_Scope;
+            end;
+
+         --  Otherwise, just insert after the package declaration
+
+         else
+            Insert_Action (N, Decl);
+         end if;
+      end if;
+   end Expand_N_Package_Renaming_Declaration;
+
+   ----------------------------------------------
+   -- Expand_N_Subprogram_Renaming_Declaration --
+   ----------------------------------------------
+
+   procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
+      Loc : constant Source_Ptr := Sloc (N);
+      Id  : constant Entity_Id  := Defining_Entity (N);
+
+      function Build_Body_For_Renaming return Node_Id;
+      --  Build and return the body for the renaming declaration of an equality
+      --  or inequality operator.
+
+      -----------------------------
+      -- Build_Body_For_Renaming --
+      -----------------------------
+
+      function Build_Body_For_Renaming return Node_Id is
+         Body_Id : Entity_Id;
+         Decl    : Node_Id;
+
+      begin
+         Set_Alias (Id, Empty);
+         Set_Has_Completion (Id, False);
+         Rewrite (N,
+           Make_Subprogram_Declaration (Sloc (N),
+             Specification => Specification (N)));
+         Set_Has_Delayed_Freeze (Id);
+
+         Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
+         Set_Debug_Info_Needed (Body_Id);
+
+         Decl :=
+           Make_Subprogram_Body (Loc,
+             Specification              =>
+               Make_Function_Specification (Loc,
+                 Defining_Unit_Name       => Body_Id,
+                 Parameter_Specifications => Copy_Parameter_List (Id),
+                 Result_Definition        =>
+                   New_Occurrence_Of (Standard_Boolean, Loc)),
+             Declarations               => Empty_List,
+             Handled_Statement_Sequence => Empty);
+
+         return Decl;
+      end Build_Body_For_Renaming;
+
+      --  Local variables
+
+      Nam : constant Node_Id := Name (N);
+
+   --  Start of processing for Expand_N_Subprogram_Renaming_Declaration
+
+   begin
+      --  When the prefix of the name is a function call, we must force the
+      --  call to be made by removing side effects from the call, since we
+      --  must only call the function once.
+
+      if Nkind (Nam) = N_Selected_Component
+        and then Nkind (Prefix (Nam)) = N_Function_Call
+      then
+         Remove_Side_Effects (Prefix (Nam));
+
+      --  For an explicit dereference, the prefix must be captured to prevent
+      --  reevaluation on calls through the renaming, which could result in
+      --  calling the wrong subprogram if the access value were to be changed.
+
+      elsif Nkind (Nam) = N_Explicit_Dereference then
+         Force_Evaluation (Prefix (Nam));
+      end if;
+
+      --  Handle cases where we build a body for a renamed equality
+
+      if Is_Entity_Name (Nam)
+        and then Chars (Entity (Nam)) = Name_Op_Eq
+        and then Scope (Entity (Nam)) = Standard_Standard
+      then
+         declare
+            Left  : constant Entity_Id := First_Formal (Id);
+            Right : constant Entity_Id := Next_Formal (Left);
+            Typ   : constant Entity_Id := Etype (Left);
+            Decl  : Node_Id;
+
+         begin
+            --  Check whether this is a renaming of a predefined equality on an
+            --  untagged record type (AI05-0123).
+
+            if Ada_Version >= Ada_2012
+              and then Is_Record_Type (Typ)
+              and then not Is_Tagged_Type (Typ)
+              and then not Is_Frozen (Typ)
+            then
+               --  Build body for renamed equality, to capture its current
+               --  meaning. It may be redefined later, but the renaming is
+               --  elaborated where it occurs. This is technically known as
+               --  Squirreling semantics. Renaming is rewritten as a subprogram
+               --  declaration, and the generated  body is inserted into the
+               --  freeze actions for the subprogram.
+
+               Decl := Build_Body_For_Renaming;
+
+               Set_Handled_Statement_Sequence (Decl,
+                 Make_Handled_Sequence_Of_Statements (Loc,
+                   Statements => New_List (
+                     Make_Simple_Return_Statement (Loc,
+                       Expression =>
+                         Expand_Record_Equality
+                           (Id,
+                            Typ    => Typ,
+                            Lhs    => Make_Identifier (Loc, Chars (Left)),
+                            Rhs    => Make_Identifier (Loc, Chars (Right)),
+                            Bodies => Declarations (Decl))))));
+
+               Append_Freeze_Action (Id, Decl);
+            end if;
+         end;
+      end if;
+   end Expand_N_Subprogram_Renaming_Declaration;
+
+end Exp_Ch8;