Skip to content

R
riscv-gcc-1
Commit d0dd5209 by Javier Miranda Committed by Arnaud Charlet
Options

a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to the package. 

2007-04-20  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads, a-tags.adb (Tag_Size): This constant is now internal to
	the package.
	(Object_Specific_Data_Array): This is now internal to the package.
	(Object_Specific_Data): This is now internal to the package.
	(Select_Specific_Data_Element): This is now internal to the package.
	(Select_Specific_Data_Array): This is now internal to the package.
	(Select_Specific_Data): This is now internal to the package.
	(Offset_To_Top_Function_Ptr): This is now public.
	(To_Offset_To_Top_Function_Ptr): Removed.
	(Storage_Offset_Ptr,To_Storage_Offset_Ptr): These declarations are now
	 local to subprogram Offset_To_Top.
	(Predefined_DT): Removed.
	(Typeinfo_Ptr): Removed.
	(OSD): This function is now internal to this package.
	(SSD): This function is now internal to this package.
	(DT): New function that displaces the pointer to the table of primitives
	 to get access to the enclosing wrapper record.
	(IW_Membership): Code cleanup.
	(Offset_To_Top): Code cleanup.
	(Predefined_DT): Removed.
	(Register_Interface_Tag): Removed.
	(Set_Interface_Table): Removed.
	(Set_Offset_Index): Removed.
	(Set_Offset_To_Top): Code cleanup.
	(Set_OSD): Removed.
	(Set_Signature): Removed.
	(Set_SSD): Removed.
	(Set_Tagged_Kind): Removed.
	(Typeinfo_Ptr): Removed.
	(TSD): Removed.
	(Displace): Add missing check on null actual.

	* exp_disp.ads, exp_disp.adb
	(Select_Expansion_Utilities): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved to exp_atags.
	(Expand_Dispatching_Call): Update calls to Get_Prim_Op_Address because
	the interface requires a new parameter.
	(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
	Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Replace
	calls to subprograms Build_T, Build_S, etc. by the corresponding code.
	Done to remove package Select_Expansion_Utilities.
	(Make_DT): New implementation for statically allocated dispatch tables.
	(Make_Secondary_DT): Moved to the scope of Make_DT.
	(Register_Primitive): Code cleanup plus incoporate the use of the new
	function DT_Address_Attribute.
	(Expand_Interface_Thunk): The profile of this subprogram has been
	changed to return the Thunk_Id and the corresponding code.
	(Fill_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Fill_Secondary_DT_Entry): Removed. Its functionality is now provided by
	subprogram Register_Primitive.
	(Register_Primitive): New subprogram that incorporates the previous
	functionalities of Fill_DT_Entry and Fill_Secondary_DT_Entry.
	(Build_Common_Dispatching_Select_Statements): Remove formal Typ. This
	was only required to call Make_DT_Access_Action, which is now removed.
	(Ada_Actions): Removed
	(Action_Is_Proc): Removed
	(Action_Nb_Arg): Removed
	Replace all the calls to Make_DT_Access_Action by direct calls to
	Make_Procedure_Call_Statement or Make_Function_Call.
	(Set_DTC_Entity_Value): New subprogram.
	(Set_All_DT_Position): Add call to new subprogram Set_DTC_Entity_Value.
	(Expand_Interface_Thunk): Add missing support for primitives that are
	functions with a controlling result (case in which there is no need
	to generate the thunk).

	* exp_atag.ads, exp_atag.adb
	(Build_DT): New subprogram that displaces the pointer to reference the
	base of the wrapper record.
	(Build_Typeinfo_Offset): Removed.
	(RTE_Tag_Node): Removed.
	(Build_Common_Dispatching_Select_Statements): Moved here from exp_disp
	(Build_Get_RC_Offset): Removed.
	(Build_Inherit_Predefined_Prims): Removed.
	(Build_Inherit_TSD: Removed.
	(Build_New_TSD): Removed.
	(Build_Set_External_Tag): Removed.
	(Build_Set_Predefined_Prim_Op_Address): Add documentation.
	(Build_Set_Prim_Op_Address): Add documentation.
	(Build_Set_TSD): Removed.

	* rtsfind.ads, rtsfind.adb
	(Load_Fail): If load fails and we are not in configurable run-time
	mode, then raise Unrecoverable_Error.
	(Text_IO_Kludge): Generate an error message if a run-time library is
	not available in a given run-time (ie. zfp run-time).
	(RTE_Record_Component): Add code to check that the component we search
	for is not found in two records in the given run-time package.
	(RE_DT_Offset_To_Top_Size, RE_DT_Predef_Prims_Size): Removed
	(RE_DT_Predef_Prims_Offset): New entity
	(RE_Static_Offset_To_Top): New entity
	(RE_HT_Link): New entity.
	(System_Address_Image): Addition of this run-time package.
	(RE_Address_Image): New entity.
	(RE_Abstract_Interface): Removed.
	(RE_Default_Prim_Op_Count): Removed.
	(RE_DT_Entry_Size): Removed.
	(RE_DT_Min_Prologue_Size): Removed.
	(RE_DT_Prologue_Size): Removed.
	(RE_Ifaces_Table_Ptr): Removed.
	(RE_Interface_Data_Ptr): Removed.
	(RE_Type_Specific_Data): Removed.
	(RE_Primary_DT): Removed.
	(RE_Register_Interface_Tag): Removed.
	(RE_Set_Offset_Index): Removed.
	(RE_Set_OSD): Removed.
	(RE_Set_SSD): Removed.
	(RE_Set_Signature): Removed.
	(RE_Set_Tagged_Kind): Removed.
	(RE_Address_Array): New entity.
	(RE_DT): New entity.
	(RE_Iface_Tag): New entity.
	(RE_Interfaces_Table): New entity.
	(RE_No_Dispatch_Table): New entity.
	(RE_NDT_Prims_Ptr): New entity.
	(RE_NDT_TSD): New entity.
	(RE_Num_Prims): New entity.
	(RE_Offset_To_Top_Function_Ptr): New entity.
	(RE_OSD_Table): New entity.
	(RE_OSD_Num_Prims): New entity.
	(RE_Predef_Prims): New entity
	(RE_Predef_Prims_Table_Ptr): New entity.
	(RE_Primary_DT): New entity.
	(RE_Signature): New entity.
	(RE_SSD): New entity.
	(RE_TSD): New entity.
	(RE_Type_Specific_Data): New entity.
	(RE_Tag_Kind): New entity.

From-SVN: r125379
parent dc1f64ac
Showing with 132 additions and 165 deletions
gcc/ada/exp_atag.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, Free Software Foundation, Inc. --
-- Copyright (C) 2006-2007, 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- --
......@@ -28,18 +28,24 @@
-- subprograms of package Ada.Tags
with Types; use Types;
with Uintp; use Uintp;
package Exp_Atag is
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
DT_Ptr : Entity_Id;
Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
function Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id;
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each
-- dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table
-- of ancestors that are contained in the dispatch table referenced by
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-- has a table of ancestors and its inheritance level (Idepth). Obj is in
-- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula:
--
......@@ -54,9 +60,9 @@ package Exp_Atag is
-- Generates: TSD (Tag).Access_Level
function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
-- Given a pointer to a dispatch table (T) and a position in the DT, build
-- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls).
......@@ -64,29 +70,22 @@ package Exp_Atag is
-- Generates: Predefined_DT (Tag).D (Position);
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
-- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls).
--
-- Generates: To_Tag (Tag).D (Position);
function Build_Get_RC_Offset
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the Offset of the implicit record controller
-- when the object has controlled components. O otherwise.
--
-- Generates: TSD (T).RC_Offset;
function Build_Get_Remotely_Callable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the value previously saved by Set_Remotely
-- Callable
function Build_Get_Transportable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the value of the Transportable flag for
-- the given Tag.
--
-- Generates: TSD (Tag).Remotely_Callable
-- Generates: TSD (Tag).Transportable;
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
......@@ -96,6 +95,8 @@ package Exp_Atag is
--
-- 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.
function Build_Inherit_Prims
(Loc : Source_Ptr;
......@@ -103,80 +104,39 @@ package Exp_Atag is
New_Tag_Node : Node_Id;
Num_Prims : Nat) return Node_Id;
-- Build code that inherits Num_Prims user-defined primitives from the
-- dispatch table of the parent type.
-- dispatch table of the parent type. It is used to copy the dispatch
-- table of the parent in case of derivations of CPP_Class types.
--
-- Generates:
-- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
-- Old_Tag.Prims_Ptr (1 .. Num_Prims);
function Build_Inherit_TSD
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
I_Depth : Nat;
Parent_Num_Ifaces : Nat) return Node_Id;
-- Generates code that initializes the TSD of a type knowing the tag,
-- inheritance depth, and number of interface types of the parent type.
--
-- Generates:
-- -- Copy the table of ancestors of the parent
--
-- TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
--
-- -- Copy the table of interfaces of the parent
--
-- if TSD (Old_Tag).Ifaces_Table_Ptr /= null then
-- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
-- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
-- end if;
--
-- TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_New_TSD
(Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id;
-- Build code that initializes the TSD of a root type.
-- Generates: TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the string containing the external
-- tag in the dispatch table.
--
-- Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value);
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the portion of the dispatch table associated with the
-- predefined primitives of Tag (used for overriding).
-- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry
-- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for:
-- 1) Filling the dispatch table of CPP_Class types.
-- 2) Late overriding (see Check_Dispatching_Operation).
--
-- Generates: Predefined_DT (Tag).D (Position) := Value
function Build_Set_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the dispatch table associated with the Tag (used for
-- overriding).
-- Position of the dispatch table associated with the Tag. Called from
-- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for:
-- 1) Filling the dispatch table of CPP_Class types.
-- 2) Late overriding (see Check_Dispatching_Operation).
--
-- Generates: Tag.D (Position) := Value
function Build_Set_TSD
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value
end Exp_Atag;
gcc/ada/exp_disp.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_disp.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -111,7 +111,7 @@ package Exp_Disp is
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Timed_Entry_Call for more information.
-- Lifecycle of predefined primitive operations
-- Life cycle of predefined primitive operations
-- The specifications and bodies of the PPOs are created by
-- Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies
......@@ -122,16 +122,14 @@ package Exp_Disp is
-- PPOs are collected and added to the Primitive_Operations list of
-- a type by the regular analysis mechanism.
-- PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3.
-- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze.
-- Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a
-- call to Register_Predefined_DT_Entry, also in Exp_Ch6.
-- Thunks for PPOs are created by Make_DT.
-- Dispatch table positions of PPOs are set in Set_All_DT_Position in
-- Exp_Disp.
-- Dispatch table positions of PPOs are set by Set_All_DT_Position.
-- Calls to PPOs procede as regular dispatching calls. If the PPO
-- has a thunk, a call procedes as a regular dispatching call with
-- Calls to PPOs proceed as regular dispatching calls. If the PPO
-- has a thunk, a call proceeds as a regular dispatching call with
-- a thunk.
-- Guidelines for addition of new predefined primitive operations
......@@ -167,21 +165,6 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
type DT_Access_Action is
(IW_Membership,
Get_Entry_Index,
Get_Prim_Op_Kind,
Get_Tagged_Kind,
Register_Interface_Tag,
Register_Tag,
Set_Entry_Index,
Set_Offset_Index,
Set_OSD,
Set_Prim_Op_Kind,
Set_Signature,
Set_SSD,
Set_Tagged_Kind);
procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types tag checks are
......@@ -198,41 +181,22 @@ package Exp_Disp is
-- the object to give access to the interface tag associated with the
-- secondary dispatch table.
function Expand_Interface_Thunk
procedure Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id) return Node_Id;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id);
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
-- the call (that is, the pointer to the object) before transferring
-- control to the target function.
function Fill_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id) return Node_Id;
-- Generate the code necessary to fill the appropriate entry of the
-- dispatch table of Prim's controlling type with Prim's address.
function Fill_Secondary_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id;
Thunk_Id : Entity_Id;
Iface_DT_Ptr : Entity_Id) return Node_Id;
-- (Ada 2005): Generate the code necessary to fill the appropriate entry of
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- address.
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
Args : List_Id) return Node_Id;
-- Generate a call to one of the Dispatch Table Access Subprograms defined
-- in Ada.Tags or in Interfaces.Cpp
--
-- Required in 3.4 case, why ??? giant comment needed for any gcc
-- specific code ???
function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table (or the Vtable in
-- the case of type whose ancestor is a CPP_Class)
-- Expand the declarations for the Dispatch Table.
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;
......@@ -284,8 +248,8 @@ package Exp_Disp is
function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in timed selects. Generate a null body if Nul
-- is an interface type.
-- Typ used for dispatching in timed selects. Generates a body containing
-- a single null-statement if Typ is an interface type.
function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id;
......@@ -299,20 +263,19 @@ package Exp_Disp is
-- selects. Generate code to set the primitive operation kinds and entry
-- indices of primitive operations and primitive wrappers.
procedure Make_Secondary_DT
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Nat;
Iface : Entity_Id;
AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
Result : out List_Id);
-- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
-- Table of Typ associated with Iface (each abstract interface implemented
-- by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ
-- and Suffix_Index are used to generate an unique external name which
-- is added at the end of Acc_Disp_Tables; this external name will be
-- used later by the subprogram Exp_Ch3.Build_Init_Procedure.
procedure Register_Primitive
(Loc : Source_Ptr;
Prim : Entity_Id;
Ins_Nod : Node_Id);
-- Register Prim in the corresponding primary or secondary dispatch table.
-- If Prim is associated with a secondary dispatch table then generate also
-- its thunk and register it in the associated secondary dispatch table.
-- In general the dispatch tables are always generated by Make_DT and
-- Make_Secondary_DT; this routine is only used in two corner cases:
-- 1) To construct the dispatch table of a tagged type whose parent
-- is a CPP_Class (see Build_Init_Procedure).
-- 2) To handle late overriding of dispatching operations (see
-- Check_Dispatching_Operation).
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP
......@@ -324,6 +287,12 @@ package Exp_Disp is
-- be the default constructor (i.e. the function returning this type,
-- having a pragma CPP_Constructor and no parameter)
procedure Set_DTC_Entity_Value
(Tagged_Type : Entity_Id;
Prim : Entity_Id);
-- Set the definite value of the DTC_Entity value associated with a given
-- primitive of a tagged type.
procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb)
......
gcc/ada/rtsfind.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -541,7 +541,15 @@ package body Rtsfind is
Output_Entity_Name (Id, "not available");
end if;
raise RE_Not_Available;
-- In configurable run time mode, we raise RE_Not_Available, and we hope
-- the caller deals gracefully with this. If we are in normal full run
-- time mode, a load failure is considered fatal and unrecoverable.
if Configurable_Run_Time_Mode then
raise RE_Not_Available;
else
raise Unrecoverable_Error;
end if;
end Load_Fail;
--------------
......@@ -683,12 +691,24 @@ package body Rtsfind is
Set_Analyzed (Cunit (Current_Sem_Unit), True);
if not Analyzed (Cunit (U.Unum)) then
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
Load_Fail ("had semantic errors", U_Id, Id);
-- If the unit is already loaded through a limited_with clauses,
-- the relevant entities must already be available. We do not
-- want to load and analyze the unit because this would create
-- a real semantic dependence when the purpose of the limited_with
-- is precisely to avoid such.
if From_With_Type (Cunit_Entity (U.Unum)) then
null;
else
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
Load_Fail ("had semantic errors", U_Id, Id);
end if;
end if;
end if;
......@@ -891,7 +911,8 @@ package body Rtsfind is
-----------------------
function Find_Local_Entity (E : RE_Id) return Entity_Id is
RE_Str : String renames RE_Id'Image (E);
RE_Str : constant String := RE_Id'Image (E);
Nam : Name_Id;
Ent : Entity_Id;
Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
......@@ -902,7 +923,8 @@ package body Rtsfind is
Name_Buffer (1 .. Name_Len) :=
RE_Str (RE_Str'First + 3 .. RE_Str'Last);
Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
Nam := Name_Find;
Ent := Entity_Id (Get_Name_Table_Info (Nam));
Name_Len := Save_Nam'Length;
Name_Buffer (1 .. Name_Len) := Save_Nam;
......@@ -956,9 +978,16 @@ package body Rtsfind is
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
-- First we search the package entity chain
-- First we search the package entity chain. If the package
-- only has a limited view, scan the corresponding list of
-- incomplete types.
if From_With_Type (U.Entity) then
Pkg_Ent := First_Entity (Limited_View (U.Entity));
else
Pkg_Ent := First_Entity (U.Entity);
end if;
Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent;
......@@ -1067,6 +1096,7 @@ package body Rtsfind is
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
E1 : Entity_Id;
Ename : Name_Id;
Found_E : Entity_Id;
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
......@@ -1103,13 +1133,15 @@ package body Rtsfind is
-- Search the entity in the components of record type declarations
-- found in the package entity chain.
Found_E := Empty;
Pkg_Ent := First_Entity (U.Entity);
Search : while Present (Pkg_Ent) loop
if Is_Record_Type (Pkg_Ent) then
E1 := First_Entity (Pkg_Ent);
while Present (E1) loop
if Ename = Chars (E1) then
exit Search;
pragma Assert (not Present (Found_E));
Found_E := E1;
end if;
Next_Entity (E1);
......@@ -1157,7 +1189,7 @@ package body Rtsfind is
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, E1);
return Check_CRT (E, Found_E);
end RTE_Record_Component;
------------------------------------
......@@ -1366,6 +1398,12 @@ package body Rtsfind is
end if;
end loop;
end if;
exception
-- Generate error message if run-time unit not available
when RE_Not_Available =>
Error_Msg_N ("& not available", Nam);
end Text_IO_Kludge;
end Rtsfind;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment