exp_disp.adb (Make_DT, [...]): Set attribute Is_Static_Dispatch_Table
2008-03-26 Javier Miranda <miranda@adacore.com> * exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute Is_Static_Dispatch_Table (Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls to Exchange_Declarations to exchange the private and full-view. Bug found working in this issue. (Expand_Dispatching_Call): Propagate the convention of the subprogram to the subprogram pointer type. (Make_Secondary_DT): Replace generation of Prim'Address by Address (Prim'Unrestricted_Access) (Make_DT): Replace generation of Prim'Address by Address (Prim'Unrestricted_Access) (Make_Disp_*_Bodies): When compiling for a restricted profile, use simple call form for single entry. (Make_DT): Handle new contents of Access_Disp_Table (access to dispatch tables of predefined primitives). (Make_Secondary_DT): Add support to handle access to dispatch tables of predefined primitives. (Make_Tags): Add entities to Access_Dispatch_Table associated with access to dispatch tables containing predefined primitives. * exp_ch6.adb (N_Pragma): Chars field removed, use Chars (Pragma_Identifier (.. instead, adjustments throughout to accomodate this change. (Register_Predefined_DT_Entry): Updated to handle the new contents of attribute Access_Disp_Table (pointers to dispatch tables containing predefined primitives). * exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New subprogram. (Find_Interface_ADT): Updated to skip the new contents of attribute Access_Dispatch_Table (pointers to dispatch tables containing predefined primitives). * sem_util.adb (Has_Abstract_Interfaces): Add missing support for concurrent types. (Set_Convention): Use new function Is_Access_Subprogram_Type (Collect_Interfaces_Info): Updated to skip the new contents of attribute Access_Dispatch_Table (pointers to dispatch tables containing predefined primitives). * exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve expanded code avoiding calls to Build_Predef_Prims. (Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding call to Build_Get_Predefined_Prim_Op_Address. From-SVN: r133564
This commit is contained in:
Javier Miranda
Arnaud Charlet
parent
50cff36721
commit
1923d2d671
@ -369,64 +369,32 @@ package body Exp_Atag is
|
||||
New_Tag_Node : Node_Id) return Node_Id
|
||||
is
|
||||
begin
|
||||
if RTE_Available (RE_DT) then
|
||||
return
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix =>
|
||||
Build_DT (Loc, New_Tag_Node),
|
||||
Selector_Name =>
|
||||
New_Reference_To
|
||||
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
|
||||
Discrete_Range => Make_Range (Loc,
|
||||
Make_Integer_Literal (Loc, Uint_1),
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
|
||||
return
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
|
||||
New_Tag_Node)))),
|
||||
Discrete_Range => Make_Range (Loc,
|
||||
Make_Integer_Literal (Loc, Uint_1),
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
|
||||
|
||||
Expression =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix =>
|
||||
Build_DT (Loc, Old_Tag_Node),
|
||||
Selector_Name =>
|
||||
New_Reference_To
|
||||
(RTE_Record_Component (RE_Predef_Prims), Loc)))),
|
||||
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Low_Bound => Make_Integer_Literal (Loc, 1),
|
||||
High_Bound =>
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
|
||||
else
|
||||
return
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Build_Predef_Prims (Loc, New_Tag_Node)),
|
||||
Discrete_Range => Make_Range (Loc,
|
||||
Make_Integer_Literal (Loc, Uint_1),
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
|
||||
|
||||
Expression =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Build_Predef_Prims (Loc, Old_Tag_Node)),
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Low_Bound => Make_Integer_Literal (Loc, 1),
|
||||
High_Bound =>
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
|
||||
end if;
|
||||
Expression =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
|
||||
Old_Tag_Node)))),
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Make_Integer_Literal (Loc, 1),
|
||||
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
|
||||
end Build_Inherit_Predefined_Prims;
|
||||
|
||||
------------------------
|
||||
@ -472,8 +440,15 @@ package body Exp_Atag is
|
||||
begin
|
||||
return
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Build_Get_Predefined_Prim_Op_Address (Loc,
|
||||
Tag_Node, Position),
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
|
||||
Expressions =>
|
||||
New_List (Make_Integer_Literal (Loc, Position))),
|
||||
|
||||
Expression => Address_Node);
|
||||
end Build_Set_Predefined_Prim_Op_Address;
|
||||
|
||||
|
||||
@ -90,15 +90,16 @@ package Exp_Atag is
|
||||
-- Generates: TSD (Tag).Transportable;
|
||||
|
||||
function Build_Inherit_Predefined_Prims
|
||||
(Loc : Source_Ptr;
|
||||
Old_Tag_Node : Node_Id;
|
||||
New_Tag_Node : Node_Id) return Node_Id;
|
||||
(Loc : Source_Ptr;
|
||||
Old_Tag_Node : Node_Id;
|
||||
New_Tag_Node : Node_Id) return Node_Id;
|
||||
-- Build code that inherits the predefined primitives of the parent.
|
||||
--
|
||||
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
|
||||
-- Predefined_DT (Old_T).D (All_Predefined_Prims);
|
||||
--
|
||||
-- Required to build the dispatch tables with the 3.4 backend.
|
||||
-- Required to build non-library level dispatch tables. Also required
|
||||
-- when compiling without static dispatch tables support.
|
||||
|
||||
function Build_Inherit_Prims
|
||||
(Loc : Source_Ptr;
|
||||
|
||||
@ -3388,7 +3388,7 @@ package body Exp_Ch6 is
|
||||
-- not be posting warnings on the inlined body so it is unneeded.
|
||||
|
||||
elsif Nkind (N) = N_Pragma
|
||||
and then Chars (N) = Name_Unreferenced
|
||||
and then Pragma_Name (N) = Name_Unreferenced
|
||||
then
|
||||
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
||||
return OK;
|
||||
@ -4756,14 +4756,14 @@ package body Exp_Ch6 is
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Skip the first access-to-dispatch-table pointer since it leads
|
||||
-- to the primary dispatch table. We are only concerned with the
|
||||
-- secondary dispatch table pointers. Note that the access-to-
|
||||
-- dispatch-table pointer corresponds to the first implemented
|
||||
-- interface retrieved below.
|
||||
-- Skip the first two access-to-dispatch-table pointers since they
|
||||
-- leads to the primary dispatch table (predefined DT and user
|
||||
-- defined DT). We are only concerned with the secondary dispatch
|
||||
-- table pointers. Note that the access-to- dispatch-table pointer
|
||||
-- corresponds to the first implemented interface retrieved below.
|
||||
|
||||
Iface_DT_Ptr :=
|
||||
Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
|
||||
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
|
||||
|
||||
while Present (Iface_DT_Ptr)
|
||||
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
|
||||
@ -4776,23 +4776,41 @@ package body Exp_Ch6 is
|
||||
Thunk_Code,
|
||||
|
||||
Build_Set_Predefined_Prim_Op_Address (Loc,
|
||||
Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
|
||||
Tag_Node =>
|
||||
New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
|
||||
Position => DT_Position (Prim),
|
||||
Address_Node =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Thunk_Id, Loc),
|
||||
Attribute_Name => Name_Address)),
|
||||
Unchecked_Convert_To (RTE (RE_Address),
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Thunk_Id, Loc),
|
||||
Attribute_Name => Name_Unrestricted_Access))),
|
||||
|
||||
Build_Set_Predefined_Prim_Op_Address (Loc,
|
||||
Tag_Node => New_Reference_To
|
||||
(Node (Next_Elmt (Iface_DT_Ptr)), Loc),
|
||||
Tag_Node =>
|
||||
New_Reference_To
|
||||
(Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
|
||||
Loc),
|
||||
Position => DT_Position (Prim),
|
||||
Address_Node =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Prim, Loc),
|
||||
Attribute_Name => Name_Address))));
|
||||
Unchecked_Convert_To (RTE (RE_Address),
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Prim, Loc),
|
||||
Attribute_Name => Name_Unrestricted_Access)))));
|
||||
end if;
|
||||
|
||||
-- Skip the tag of the predefined primitives dispatch table
|
||||
|
||||
Next_Elmt (Iface_DT_Ptr);
|
||||
pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
|
||||
|
||||
-- Skip the tag of the no-thunks dispatch table
|
||||
|
||||
Next_Elmt (Iface_DT_Ptr);
|
||||
pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
|
||||
|
||||
-- Skip the tag of the predefined primitives no-thunks dispatch
|
||||
-- table
|
||||
|
||||
Next_Elmt (Iface_DT_Ptr);
|
||||
pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2008, 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- --
|
||||
@ -948,6 +948,43 @@ package body Exp_Util is
|
||||
end if;
|
||||
end Component_May_Be_Bit_Aligned;
|
||||
|
||||
-----------------------------------
|
||||
-- Corresponding_Runtime_Package --
|
||||
-----------------------------------
|
||||
|
||||
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
|
||||
Pkg_Id : RTU_Id := RTU_Null;
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Concurrent_Type (Typ));
|
||||
|
||||
if Ekind (Typ) in Protected_Kind then
|
||||
if Has_Entries (Typ)
|
||||
or else Has_Interrupt_Handler (Typ)
|
||||
or else (Has_Attach_Handler (Typ)
|
||||
and then not Restricted_Profile)
|
||||
or else (Ada_Version >= Ada_05
|
||||
and then Present (Interface_List (Parent (Typ))))
|
||||
then
|
||||
if Abort_Allowed
|
||||
or else Restriction_Active (No_Entry_Queue) = False
|
||||
or else Number_Entries (Typ) > 1
|
||||
or else (Has_Attach_Handler (Typ)
|
||||
and then not Restricted_Profile)
|
||||
then
|
||||
Pkg_Id := System_Tasking_Protected_Objects_Entries;
|
||||
else
|
||||
Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
|
||||
end if;
|
||||
|
||||
else
|
||||
Pkg_Id := System_Tasking_Protected_Objects;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Pkg_Id;
|
||||
end Corresponding_Runtime_Package;
|
||||
|
||||
-------------------------------
|
||||
-- Convert_To_Actual_Subtype --
|
||||
-------------------------------
|
||||
@ -1384,6 +1421,10 @@ package body Exp_Util is
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Document what is going on here, why four Next's???
|
||||
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (AI_Elmt);
|
||||
@ -1420,7 +1461,7 @@ package body Exp_Util is
|
||||
(not Is_Class_Wide_Type (Typ)
|
||||
and then Ekind (Typ) /= E_Incomplete_Type);
|
||||
|
||||
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
|
||||
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
|
||||
pragma Assert (Present (Node (ADT)));
|
||||
Find_Secondary_Table (Typ);
|
||||
pragma Assert (Found);
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2008, 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- --
|
||||
@ -212,43 +212,51 @@ package Exp_Util is
|
||||
-- function itself must do its own cleanups.
|
||||
|
||||
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
|
||||
-- This function is in charge of detecting record components that may cause
|
||||
-- trouble in the back end if an attempt is made to assign the component.
|
||||
-- The back end can handle such assignments with no problem if the
|
||||
-- components involved are small (64-bits or less) records or scalar items
|
||||
-- (including bit-packed arrays represented with modular types) or are both
|
||||
-- aligned on a byte boundary (starting on a byte boundary, and occupying
|
||||
-- an integral number of bytes).
|
||||
-- This function is in charge of detecting record components that may
|
||||
-- cause trouble in the back end if an attempt is made to assign the
|
||||
-- component. The back end can handle such assignments with no problem if
|
||||
-- the components involved are small (64-bits or less) records or scalar
|
||||
-- items (including bit-packed arrays represented with modular types) or
|
||||
-- are both aligned on a byte boundary (starting on a byte boundary, and
|
||||
-- occupying an integral number of bytes).
|
||||
--
|
||||
-- However, problems arise for records larger than 64 bits, or for arrays
|
||||
-- (other than bit-packed arrays represented with a modular type) if the
|
||||
-- component starts on a non-byte boundary, or does not occupy an integral
|
||||
-- number of bytes (i.e. there are some bits possibly shared with fields at
|
||||
-- the start or beginning of the component). The back end cannot handle
|
||||
-- number of bytes (i.e. there are some bits possibly shared with fields
|
||||
-- at the start or beginning of the component). The back end cannot handle
|
||||
-- loading and storing such components in a single operation.
|
||||
--
|
||||
-- This function is used to detect the troublesome situation. it is
|
||||
-- conservative in the sense that it produces True unless it knows for sure
|
||||
-- that the component is safe (as outlined in the first paragraph above).
|
||||
-- The code generation for record and array assignment checks for trouble
|
||||
-- using this function, and if so the assignment is generated
|
||||
-- conservative in the sense that it produces True unless it knows for
|
||||
-- sure that the component is safe (as outlined in the first paragraph
|
||||
-- above). The code generation for record and array assignment checks for
|
||||
-- trouble using this function, and if so the assignment is generated
|
||||
-- component-wise, which the back end is required to handle correctly.
|
||||
--
|
||||
-- Note that in GNAT 3, the back end will reject such components anyway, so
|
||||
-- the hard work in checking for this case is wasted in GNAT 3, but it's
|
||||
-- harmless, so it is easier to do it in all cases, rather than
|
||||
-- Note that in GNAT 3, the back end will reject such components anyway,
|
||||
-- so the hard work in checking for this case is wasted in GNAT 3, but
|
||||
-- it is harmless, so it is easier to do it in all cases, rather than
|
||||
-- conditionalize it in GNAT 5 or beyond.
|
||||
|
||||
procedure Convert_To_Actual_Subtype (Exp : Node_Id);
|
||||
-- The Etype of an expression is the nominal type of the expression, not
|
||||
-- the actual subtype. Often these are the same, but not always. For
|
||||
-- example, a reference to a formal of unconstrained type has the
|
||||
-- The Etype of an expression is the nominal type of the expression,
|
||||
-- not the actual subtype. Often these are the same, but not always.
|
||||
-- For example, a reference to a formal of unconstrained type has the
|
||||
-- unconstrained type as its Etype, but the actual subtype is obtained by
|
||||
-- applying the actual bounds. This routine is given an expression, Exp,
|
||||
-- and (if necessary), replaces it using Rewrite, with a conversion to the
|
||||
-- actual subtype, building the actual subtype if necessary. If the
|
||||
-- and (if necessary), replaces it using Rewrite, with a conversion to
|
||||
-- the actual subtype, building the actual subtype if necessary. If the
|
||||
-- expression is already of the requested type, then it is unchanged.
|
||||
|
||||
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id;
|
||||
-- Return the id of the runtime package that will provide support for
|
||||
-- concurrent type Typ. Currently only protected types are supported,
|
||||
-- and the returned value is one of the following:
|
||||
-- System_Tasking_Protected_Objects
|
||||
-- System_Tasking_Protected_Objects_Entries
|
||||
-- System_Tasking_Protected_Objects_Single_Entry
|
||||
|
||||
function Current_Sem_Unit_Declarations return List_Id;
|
||||
-- Return the a place where it is fine to insert declarations for the
|
||||
-- current semantic unit. If the unit is a package body, return the
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2008, 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- --
|
||||
@ -1386,12 +1386,15 @@ package body Sem_Util is
|
||||
ADT : Elmt_Id;
|
||||
|
||||
begin
|
||||
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
|
||||
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
|
||||
while Present (ADT)
|
||||
and then Ekind (Node (ADT)) = E_Constant
|
||||
and then Related_Type (Node (ADT)) /= Iface
|
||||
loop
|
||||
-- Skip the two secondary dispatch tables of Iface
|
||||
-- Skip the secondary dispatch tables of Iface
|
||||
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
Next_Elmt (ADT);
|
||||
end loop;
|
||||
@ -3769,6 +3772,15 @@ package body Sem_Util is
|
||||
return Entity_Id (Get_Name_Table_Info (Id));
|
||||
end Get_Name_Entity_Id;
|
||||
|
||||
-------------------
|
||||
-- Get_Pragma_Id --
|
||||
-------------------
|
||||
|
||||
function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
|
||||
begin
|
||||
return Get_Pragma_Id (Pragma_Name (N));
|
||||
end Get_Pragma_Id;
|
||||
|
||||
---------------------------
|
||||
-- Get_Referenced_Object --
|
||||
---------------------------
|
||||
@ -3906,31 +3918,42 @@ package body Sem_Util is
|
||||
-----------------------------
|
||||
|
||||
function Has_Abstract_Interfaces
|
||||
(Tagged_Type : Entity_Id;
|
||||
(T : Entity_Id;
|
||||
Use_Full_View : Boolean := True) return Boolean
|
||||
is
|
||||
Typ : Entity_Id;
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Record_Type (Tagged_Type)
|
||||
and then Is_Tagged_Type (Tagged_Type));
|
||||
-- Handle concurrent types
|
||||
|
||||
-- Handle concurrent record types
|
||||
|
||||
if Is_Concurrent_Record_Type (Tagged_Type)
|
||||
and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type))
|
||||
then
|
||||
return True;
|
||||
if Is_Concurrent_Type (T) then
|
||||
Typ := Corresponding_Record_Type (T);
|
||||
else
|
||||
Typ := T;
|
||||
end if;
|
||||
|
||||
Typ := Tagged_Type;
|
||||
if not Present (Typ)
|
||||
or else not Is_Tagged_Type (Typ)
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
pragma Assert (Is_Record_Type (Typ));
|
||||
|
||||
-- Handle private types
|
||||
|
||||
if Use_Full_View
|
||||
and then Present (Full_View (Tagged_Type))
|
||||
and then Present (Full_View (Typ))
|
||||
then
|
||||
Typ := Full_View (Tagged_Type);
|
||||
Typ := Full_View (Typ);
|
||||
end if;
|
||||
|
||||
-- Handle concurrent record types
|
||||
|
||||
if Is_Concurrent_Record_Type (Typ)
|
||||
and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
loop
|
||||
@ -3953,7 +3976,7 @@ package body Sem_Util is
|
||||
-- Protect the frontend against wrong source with cyclic
|
||||
-- derivations
|
||||
|
||||
or else Etype (Typ) = Tagged_Type;
|
||||
or else Etype (Typ) = T;
|
||||
|
||||
-- Climb to the ancestor type handling private types
|
||||
|
||||
@ -8910,8 +8933,9 @@ package body Sem_Util is
|
||||
procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
|
||||
begin
|
||||
Basic_Set_Convention (E, Val);
|
||||
|
||||
if Is_Type (E)
|
||||
and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind
|
||||
and then Is_Access_Subprogram_Type (Base_Type (E))
|
||||
and then Has_Foreign_Convention (E)
|
||||
then
|
||||
Set_Can_Use_Internal_Rep (E, False);
|
||||
@ -8932,6 +8956,93 @@ package body Sem_Util is
|
||||
Set_Name_Entity_Id (Chars (E), E);
|
||||
end Set_Current_Entity;
|
||||
|
||||
---------------------------
|
||||
-- Set_Debug_Info_Needed --
|
||||
---------------------------
|
||||
|
||||
procedure Set_Debug_Info_Needed (T : Entity_Id) is
|
||||
|
||||
procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
|
||||
pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
|
||||
-- Used to set debug info in a related node if not set already
|
||||
|
||||
--------------------------------------
|
||||
-- Set_Debug_Info_Needed_If_Not_Set --
|
||||
--------------------------------------
|
||||
|
||||
procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
|
||||
begin
|
||||
if Present (E)
|
||||
and then not Needs_Debug_Info (E)
|
||||
then
|
||||
Set_Debug_Info_Needed (E);
|
||||
end if;
|
||||
end Set_Debug_Info_Needed_If_Not_Set;
|
||||
|
||||
-- Start of processing for Set_Debug_Info_Needed
|
||||
|
||||
begin
|
||||
-- Nothing to do if argument is Empty or has Debug_Info_Off set, which
|
||||
-- indicates that Debug_Info_Needed is never required for the entity.
|
||||
|
||||
if No (T)
|
||||
or else Debug_Info_Off (T)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Set flag in entity itself. Note that we will go through the following
|
||||
-- circuitry even if the flag is already set on T. That's intentional,
|
||||
-- it makes sure that the flag will be set in subsidiary entities.
|
||||
|
||||
Set_Needs_Debug_Info (T);
|
||||
|
||||
-- Set flag on subsidiary entities if not set already
|
||||
|
||||
if Is_Object (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Etype (T));
|
||||
|
||||
elsif Is_Type (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Etype (T));
|
||||
|
||||
if Is_Record_Type (T) then
|
||||
declare
|
||||
Ent : Entity_Id := First_Entity (T);
|
||||
begin
|
||||
while Present (Ent) loop
|
||||
Set_Debug_Info_Needed_If_Not_Set (Ent);
|
||||
Next_Entity (Ent);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
elsif Is_Array_Type (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
|
||||
|
||||
declare
|
||||
Indx : Node_Id := First_Index (T);
|
||||
begin
|
||||
while Present (Indx) loop
|
||||
Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
|
||||
Indx := Next_Index (Indx);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
if Is_Packed (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
|
||||
end if;
|
||||
|
||||
elsif Is_Access_Type (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
|
||||
|
||||
elsif Is_Private_Type (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
|
||||
|
||||
elsif Is_Protected_Type (T) then
|
||||
Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
|
||||
end if;
|
||||
end if;
|
||||
end Set_Debug_Info_Needed;
|
||||
|
||||
---------------------------------
|
||||
-- Set_Entity_With_Style_Check --
|
||||
---------------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user