Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ I N T R                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, 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 Checks;   use Checks;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Errout;   use Errout;

with Exp_Atag; use Exp_Atag;

with Exp_Ch4;  use Exp_Ch4;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch11; use Exp_Ch11;

with Exp_Code; use Exp_Code;

with Exp_Fixd; use Exp_Fixd;

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 Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

package body Exp_Intr is

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Expand_Binary_Operator_Call (N : Node_Id);

   --  Expand a call to an intrinsic arithmetic operator when the operand

   --  types or sizes are not identical.

   procedure Expand_Is_Negative (N : Node_Id);

   --  Expand a call to the intrinsic Is_Negative function

   procedure Expand_Dispatching_Constructor_Call (N : Node_Id);

   --  Expand a call to an instantiation of Generic_Dispatching_Constructor

   --  into a dispatching call to the actual subprogram associated with the

   --  Constructor formal subprogram, passing it the Parameters actual of

   --  the call to the instantiation and dispatching based on call's Tag

   --  parameter.

   procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);

   --  Expand a call to Exception_Information/Message/Name. The first

   --  parameter, N, is the node for the function call, and Ent is the

   --  entity for the corresponding routine in the Ada.Exceptions package.

   procedure Expand_Import_Call (N : Node_Id);

   --  Expand a call to Import_Address/Longest_Integer/Value. The parameter

   --  N is the node for the function call.

   procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);

   --  Expand an intrinsic shift operation, N and E are from the call to

   --  Expand_Intrinsic_Call (call node and subprogram spec entity) and

   --  K is the kind for the shift node

   procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);

   --  Expand a call to an instantiation of Unchecked_Conversion into a node

   --  N_Unchecked_Type_Conversion.

   procedure Expand_Unc_Deallocation (N : Node_Id);

   --  Expand a call to an instantiation of Unchecked_Deallocation into a node

   --  N_Free_Statement and appropriate context.

   procedure Expand_To_Address (N : Node_Id);

   procedure Expand_To_Pointer (N : Node_Id);

   --  Expand a call to corresponding function, declared in an instance of

   --  System.Address_To_Access_Conversions.

   procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);

   --  Rewrite the node by the appropriate string or positive constant.

   --  Nam can be one of the following:

   --    Name_File             - expand string that is the name of source file

   --    Name_Line             - expand integer line number

   --    Name_Source_Location  - expand string of form file:line

   --    Name_Enclosing_Entity - expand string  with name of enclosing entity

   ---------------------------------

   -- Expand_Binary_Operator_Call --

   ---------------------------------

   procedure Expand_Binary_Operator_Call (N : Node_Id) is

      T1  : constant Entity_Id := Underlying_Type (Etype (Left_Opnd  (N)));

      T2  : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));

      TR  : constant Entity_Id := Etype (N);

      T3  : Entity_Id;

      Res : Node_Id;

      Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));

      --  Maximum of operand sizes

   begin

      --  Nothing to do if the operands have the same modular type

      if Base_Type (T1) = Base_Type (T2)

        and then Is_Modular_Integer_Type (T1)

      then

         return;

      end if;

      --  Use Unsigned_32 for sizes of 32 or below, else Unsigned_64

      if Siz > 32 then

         T3 := RTE (RE_Unsigned_64);

      else

         T3 := RTE (RE_Unsigned_32);

      end if;

      --  Copy operator node, and reset type and entity fields, for

      --  subsequent reanalysis.

      Res := New_Copy (N);

      Set_Etype (Res, T3);

      case Nkind (N) is

         when N_Op_And =>

            Set_Entity (Res, Standard_Op_And);

         when N_Op_Or =>

            Set_Entity (Res, Standard_Op_Or);

         when N_Op_Xor =>

            Set_Entity (Res, Standard_Op_Xor);

         when others =>

            raise Program_Error;

      end case;

      --  Convert operands to large enough intermediate type

      Set_Left_Opnd (Res,

        Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));

      Set_Right_Opnd (Res,

        Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));

      --  Analyze and resolve result formed by conversion to target type

      Rewrite (N, Unchecked_Convert_To (TR, Res));

      Analyze_And_Resolve (N, TR);

   end Expand_Binary_Operator_Call;

   -----------------------------------------

   -- Expand_Dispatching_Constructor_Call --

   -----------------------------------------

   --  Transform a call to an instantiation of Generic_Dispatching_Constructor

   --  of the form:

   --     GDC_Instance (The_Tag, Parameters'Access)

   --  to a class-wide conversion of a dispatching call to the actual

   --  associated with the formal subprogram Construct, designating The_Tag

   --  as the controlling tag of the call:

   --     T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag

   --  which will eventually be expanded to the following:

   --     T'Class (The_Tag.all (Construct'Actual'Index).all (Params))

   --  A class-wide membership test is also generated, preceding the call, to

   --  ensure that the controlling tag denotes a type in T'Class.

   procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is

      Loc        : constant Source_Ptr := Sloc (N);

      Tag_Arg    : constant Node_Id    := First_Actual (N);

      Param_Arg  : constant Node_Id    := Next_Actual (Tag_Arg);

      Subp_Decl  : constant Node_Id    := Parent (Parent (Entity (Name (N))));

      Inst_Pkg   : constant Node_Id    := Parent (Subp_Decl);

      Act_Rename : Node_Id;

      Act_Constr : Entity_Id;

      Iface_Tag  : Node_Id := Empty;

      Cnstr_Call : Node_Id;

      Result_Typ : Entity_Id;

   begin

      --  The subprogram is the third actual in the instantiation, and is

      --  retrieved from the corresponding renaming declaration. However,

      --  freeze nodes may appear before, so we retrieve the declaration

      --  with an explicit loop.

      Act_Rename := First (Visible_Declarations (Inst_Pkg));

      while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop

         Next (Act_Rename);

      end loop;

      Act_Constr := Entity (Name (Act_Rename));

      Result_Typ := Class_Wide_Type (Etype (Act_Constr));

      --  Ada 2005 (AI-251): If the result is an interface type, the function

      --  returns a class-wide interface type (otherwise the resulting object

      --  would be abstract!)

      if Is_Interface (Etype (Act_Constr)) then

         Set_Etype (Act_Constr, Result_Typ);

         --  If the result type is not parent of Tag_Arg then we need to

         --  locate the tag of the secondary dispatch table.

         if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),

                             Use_Full_View => True)

           and then Tagged_Type_Expansion

         then

            --  Obtain the reference to the Ada.Tags service before generating

            --  the Object_Declaration node to ensure that if this service is

            --  not available in the runtime then we generate a clear error.

            declare

               Fname : constant Node_Id :=

                         New_Reference_To (RTE (RE_Secondary_Tag), Loc);

            begin

               pragma Assert (not Is_Interface (Etype (Tag_Arg)));

               Iface_Tag :=

                 Make_Object_Declaration (Loc,

                   Defining_Identifier => Make_Temporary (Loc, 'V'),

                   Object_Definition   =>

                     New_Reference_To (RTE (RE_Tag), Loc),

                   Expression          =>

                     Make_Function_Call (Loc,

                       Name => Fname,

                       Parameter_Associations => New_List (

                         Relocate_Node (Tag_Arg),

                         New_Reference_To

                           (Node (First_Elmt (Access_Disp_Table

                                               (Etype (Etype (Act_Constr))))),

                            Loc))));

               Insert_Action (N, Iface_Tag);

            end;

         end if;

      end if;

      --  Create the call to the actual Constructor function

      Cnstr_Call :=

        Make_Function_Call (Loc,

          Name                   => New_Occurrence_Of (Act_Constr, Loc),

          Parameter_Associations => New_List (Relocate_Node (Param_Arg)));

      --  Establish its controlling tag from the tag passed to the instance

      --  The tag may be given by a function call, in which case a temporary

      --  should be generated now, to prevent out-of-order insertions during

      --  the expansion of that call when stack-checking is enabled.

      if Present (Iface_Tag) then

         Set_Controlling_Argument (Cnstr_Call,

           New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));

      else

         Remove_Side_Effects (Tag_Arg);

         Set_Controlling_Argument (Cnstr_Call,

           Relocate_Node (Tag_Arg));

      end if;

      --  Rewrite and analyze the call to the instance as a class-wide

      --  conversion of the call to the actual constructor.

      Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));

      Analyze_And_Resolve (N, Etype (Act_Constr));

      --  Do not generate a run-time check on the built object if tag

      --  checks are suppressed for the result type or VM_Target /= No_VM

      if Tag_Checks_Suppressed (Etype (Result_Typ))

        or else not Tagged_Type_Expansion

      then

         null;

      --  Generate a class-wide membership test to ensure that the call's tag

      --  argument denotes a type within the class. We must keep separate the

      --  case in which the Result_Type of the constructor function is a tagged

      --  type from the case in which it is an abstract interface because the

      --  run-time subprogram required to check these cases differ (and have

      --  one difference in their parameters profile).

      --  Call CW_Membership if the Result_Type is a tagged type to look for

      --  the tag in the table of ancestor tags.

      elsif not Is_Interface (Result_Typ) then

         declare

            Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);

            CW_Test_Node : Node_Id;

         begin

            Build_CW_Membership (Loc,

              Obj_Tag_Node => Obj_Tag_Node,

              Typ_Tag_Node =>

                New_Reference_To (

                   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;

      --  Call IW_Membership test if the Result_Type is an abstract interface

      --  to look for the tag in the table of interface tags.

      else

         Insert_Action (N,

           Make_Implicit_If_Statement (N,

             Condition =>

               Make_Op_Not (Loc,

                 Make_Function_Call (Loc,

                    Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),

                    Parameter_Associations => New_List (

                      Make_Attribute_Reference (Loc,

                        Prefix         => Duplicate_Subexpr (Tag_Arg),

                        Attribute_Name => Name_Address),

                      New_Reference_To (

                        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)))));

      end if;

   end Expand_Dispatching_Constructor_Call;

   ---------------------------

   -- Expand_Exception_Call --

   ---------------------------

   --  If the function call is not within an exception handler, then the call

   --  is replaced by a null string. Otherwise the appropriate routine in

   --  Ada.Exceptions is called passing the choice parameter specification

   --  from the enclosing handler. If the enclosing handler lacks a choice

   --  parameter, then one is supplied.

   procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      P   : Node_Id;

      E   : Entity_Id;

   begin

      --  Climb up parents to see if we are in exception handler

      P := Parent (N);

      loop

         --  Case of not in exception handler, replace by null string

         if No (P) then

            Rewrite (N,

              Make_String_Literal (Loc,

                Strval => ""));

            exit;

         --  Case of in exception handler

         elsif Nkind (P) = N_Exception_Handler then

            --  Handler cannot be used for a local raise, and furthermore, this

            --  is a violation of the No_Exception_Propagation restriction.

            Set_Local_Raise_Not_OK (P);

            Check_Restriction (No_Exception_Propagation, N);

            --  If no choice parameter present, then put one there. Note that

            --  we do not need to put it on the entity chain, since no one will

            --  be referencing it by normal visibility methods.

            if No (Choice_Parameter (P)) then

               E := Make_Temporary (Loc, 'E');

               Set_Choice_Parameter (P, E);

               Set_Ekind (E, E_Variable);

               Set_Etype (E, RTE (RE_Exception_Occurrence));

               Set_Scope (E, Current_Scope);

            end if;

            Rewrite (N,

              Make_Function_Call (Loc,

                Name => New_Occurrence_Of (RTE (Ent), Loc),

                Parameter_Associations => New_List (

                  New_Occurrence_Of (Choice_Parameter (P), Loc))));

            exit;

         --  Keep climbing!

         else

            P := Parent (P);

         end if;

      end loop;

      Analyze_And_Resolve (N, Standard_String);

   end Expand_Exception_Call;

   ------------------------

   -- Expand_Import_Call --

   ------------------------

   --  The function call must have a static string as its argument. We create

   --  a dummy variable which uses this string as the external name in an

   --  Import pragma. The result is then obtained as the address of this

   --  dummy variable, converted to the appropriate target type.

   procedure Expand_Import_Call (N : Node_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      Ent : constant Entity_Id  := Entity (Name (N));

      Str : constant Node_Id    := First_Actual (N);

      Dum : constant Entity_Id  := Make_Temporary (Loc, 'D');

   begin

      Insert_Actions (N, New_List (

        Make_Object_Declaration (Loc,

          Defining_Identifier => Dum,

          Object_Definition   =>

            New_Occurrence_Of (Standard_Character, Loc)),

        Make_Pragma (Loc,

          Chars => Name_Import,

          Pragma_Argument_Associations => New_List (

            Make_Pragma_Argument_Association (Loc,

              Expression => Make_Identifier (Loc, Name_Ada)),

            Make_Pragma_Argument_Association (Loc,

              Expression => Make_Identifier (Loc, Chars (Dum))),

            Make_Pragma_Argument_Association (Loc,

              Chars => Name_Link_Name,

              Expression => Relocate_Node (Str))))));

      Rewrite (N,

        Unchecked_Convert_To (Etype (Ent),

          Make_Attribute_Reference (Loc,

            Prefix         => Make_Identifier (Loc, Chars (Dum)),

            Attribute_Name => Name_Address)));

      Analyze_And_Resolve (N, Etype (Ent));

   end Expand_Import_Call;

   ---------------------------

   -- Expand_Intrinsic_Call --

   ---------------------------

   procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is

      Nam : Name_Id;

   begin

      --  If an external name is specified for the intrinsic, it is handled

      --  by the back-end: leave the call node unchanged for now.

      if Present (Interface_Name (E)) then

         return;

      end if;

      --  If the intrinsic subprogram is generic, gets its original name

      if Present (Parent (E))

        and then Present (Generic_Parent (Parent (E)))

      then

         Nam := Chars (Generic_Parent (Parent (E)));

      else

         Nam := Chars (E);

      end if;

      if Nam = Name_Asm then

         Expand_Asm_Call (N);

      elsif Nam = Name_Divide then

         Expand_Decimal_Divide_Call (N);

      elsif Nam = Name_Exception_Information then

         Expand_Exception_Call (N, RE_Exception_Information);

      elsif Nam = Name_Exception_Message then

         Expand_Exception_Call (N, RE_Exception_Message);

      elsif Nam = Name_Exception_Name then

         Expand_Exception_Call (N, RE_Exception_Name_Simple);

      elsif Nam = Name_Generic_Dispatching_Constructor then

         Expand_Dispatching_Constructor_Call (N);

      elsif Nam = Name_Import_Address

              or else

            Nam = Name_Import_Largest_Value

              or else

            Nam = Name_Import_Value

      then

         Expand_Import_Call (N);

      elsif Nam = Name_Is_Negative then

         Expand_Is_Negative (N);

      elsif Nam = Name_Rotate_Left then

         Expand_Shift (N, E, N_Op_Rotate_Left);

      elsif Nam = Name_Rotate_Right then

         Expand_Shift (N, E, N_Op_Rotate_Right);

      elsif Nam = Name_Shift_Left then

         Expand_Shift (N, E, N_Op_Shift_Left);

      elsif Nam = Name_Shift_Right then

         Expand_Shift (N, E, N_Op_Shift_Right);

      elsif Nam = Name_Shift_Right_Arithmetic then

         Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);

      elsif Nam = Name_Unchecked_Conversion then

         Expand_Unc_Conversion (N, E);

      elsif Nam = Name_Unchecked_Deallocation then

         Expand_Unc_Deallocation (N);

      elsif Nam = Name_To_Address then

         Expand_To_Address (N);

      elsif Nam = Name_To_Pointer then

         Expand_To_Pointer (N);

      elsif Nam = Name_File

        or else Nam = Name_Line

        or else Nam = Name_Source_Location

        or else Nam = Name_Enclosing_Entity

      then

         Expand_Source_Info (N, Nam);

         --  If we have a renaming, expand the call to the original operation,

         --  which must itself be intrinsic, since renaming requires matching

         --  conventions and this has already been checked.

      elsif Present (Alias (E)) then

         Expand_Intrinsic_Call (N,  Alias (E));

      elsif Nkind (N) in N_Binary_Op then

         Expand_Binary_Operator_Call (N);

         --  The only other case is where an external name was specified,

         --  since this is the only way that an otherwise unrecognized

         --  name could escape the checking in Sem_Prag. Nothing needs

         --  to be done in such a case, since we pass such a call to the

         --  back end unchanged.

      else

         null;

      end if;

   end Expand_Intrinsic_Call;

   ------------------------

   -- Expand_Is_Negative --

   ------------------------

   procedure Expand_Is_Negative (N : Node_Id) is

      Loc   : constant Source_Ptr := Sloc (N);

      Opnd  : constant Node_Id    := Relocate_Node (First_Actual (N));

   begin

      --  We replace the function call by the following expression

      --    if Opnd < 0.0 then

      --       True

      --    else

      --       if Opnd > 0.0 then

      --          False;

      --       else

      --          Float_Unsigned!(Float (Opnd)) /= 0

      --       end if;

      --    end if;

      Rewrite (N,

        Make_Conditional_Expression (Loc,

          Expressions => New_List (

            Make_Op_Lt (Loc,

              Left_Opnd  => Duplicate_Subexpr (Opnd),

              Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),

            New_Occurrence_Of (Standard_True, Loc),

            Make_Conditional_Expression (Loc,

             Expressions => New_List (

               Make_Op_Gt (Loc,

                 Left_Opnd  => Duplicate_Subexpr_No_Checks (Opnd),

                 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),

               New_Occurrence_Of (Standard_False, Loc),

                Make_Op_Ne (Loc,

                  Left_Opnd =>

                    Unchecked_Convert_To

                      (RTE (RE_Float_Unsigned),

                       Convert_To

                         (Standard_Float,

                          Duplicate_Subexpr_No_Checks (Opnd))),

                  Right_Opnd =>

                    Make_Integer_Literal (Loc, 0)))))));

      Analyze_And_Resolve (N, Standard_Boolean);

   end Expand_Is_Negative;

   ------------------

   -- Expand_Shift --

   ------------------

   --  This procedure is used to convert a call to a shift function to the

   --  corresponding operator node. This conversion is not done by the usual

   --  circuit for converting calls to operator functions (e.g. "+"(1,2)) to

   --  operator nodes, because shifts are not predefined operators.

   --  As a result, whenever a shift is used in the source program, it will

   --  remain as a call until converted by this routine to the operator node

   --  form which Gigi is expecting to see.

   --  Note: it is possible for the expander to generate shift operator nodes

   --  directly, which will be analyzed in the normal manner by calling Analyze

   --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.

   procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is

      Loc   : constant Source_Ptr := Sloc (N);

      Typ   : constant Entity_Id  := Etype (N);

      Left  : constant Node_Id    := First_Actual (N);

      Right : constant Node_Id    := Next_Actual (Left);

      Ltyp  : constant Node_Id    := Etype (Left);

      Rtyp  : constant Node_Id    := Etype (Right);

      Snode : Node_Id;

   begin

      Snode := New_Node (K, Loc);

      Set_Left_Opnd  (Snode, Relocate_Node (Left));

      Set_Right_Opnd (Snode, Relocate_Node (Right));

      Set_Chars      (Snode, Chars (E));

      Set_Etype      (Snode, Base_Type (Typ));

      Set_Entity     (Snode, E);

      if Compile_Time_Known_Value (Type_High_Bound (Rtyp))

        and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)

      then

         Set_Shift_Count_OK (Snode, True);

      end if;

      --  Do the rewrite. Note that we don't call Analyze and Resolve on

      --  this node, because it already got analyzed and resolved when

      --  it was a function call!

      Rewrite (N, Snode);

      Set_Analyzed (N);

   end Expand_Shift;

   ------------------------

   -- Expand_Source_Info --

   ------------------------

   procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      Ent : Entity_Id;

      procedure Write_Entity_Name (E : Entity_Id);

      --  Recursive procedure to construct string for qualified name of

      --  enclosing program unit. The qualification stops at an enclosing

      --  scope has no source name (block or loop). If entity is a subprogram

      --  instance, skip enclosing wrapper package.

      -----------------------

      -- Write_Entity_Name --

      -----------------------

      procedure Write_Entity_Name (E : Entity_Id) is

         SDef : Source_Ptr;

         TDef : constant Source_Buffer_Ptr :=

                  Source_Text (Get_Source_File_Index (Sloc (E)));

      begin

         --  Nothing to do if at outer level

         if Scope (E) = Standard_Standard then

            null;

         --  If scope comes from source, write its name

         elsif Comes_From_Source (Scope (E)) then

            Write_Entity_Name (Scope (E));

            Add_Char_To_Name_Buffer ('.');

         --  If in wrapper package skip past it

         elsif Is_Wrapper_Package (Scope (E)) then

            Write_Entity_Name (Scope (Scope (E)));

            Add_Char_To_Name_Buffer ('.');

         --  Otherwise nothing to output (happens in unnamed block statements)

         else

            null;

         end if;

         --  Loop to output the name

         --  is this right wrt wide char encodings ??? (no!)

         SDef := Sloc (E);

         while TDef (SDef) in '0' .. '9'

           or else TDef (SDef) >= 'A'

           or else TDef (SDef) = ASCII.ESC

         loop

            Add_Char_To_Name_Buffer (TDef (SDef));

            SDef := SDef + 1;

         end loop;

      end Write_Entity_Name;

   --  Start of processing for Expand_Source_Info

   begin

      --  Integer cases

      if Nam = Name_Line then

         Rewrite (N,

           Make_Integer_Literal (Loc,

             Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));

         Analyze_And_Resolve (N, Standard_Positive);

      --  String cases

      else

         Name_Len := 0;

         case Nam is

            when Name_File =>

               Get_Decoded_Name_String

                 (Reference_Name (Get_Source_File_Index (Loc)));

            when Name_Source_Location =>

               Build_Location_String (Loc);

            when Name_Enclosing_Entity =>

               --  Skip enclosing blocks to reach enclosing unit

               Ent := Current_Scope;

               while Present (Ent) loop

                  exit when Ekind (Ent) /= E_Block