OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch6.adb (Expand_Call): If an actual is a function call rewritten from object notation... 

2005-09-01  Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_ch6.adb (Expand_Call): If an actual is a function call rewritten
	from object notation, the original node is unanalyzed and carries no
	semantic information, so that accessiblity checks must be performed on
	the type of the actual itself.
	(Expand_N_Subprogram_Declaration): Change last actual parameter for
	compatibility with Build_Protected_Sub_Specification.
	(Check_Overriding_Inherited_Interfaces): Add suport to handle
	overloaded primitives.
	(Register_Interface_DT_Entry): Use the new name of the formal
	the the calls to Expand_Interface_Thunk

	* exp_dbug.ads: Augment comments on encoding of protected types to
	include the generation of dispatching subprograms when the type
	implements at least one interface.

	* lib.ads: Extend information in Load_Stack to include whether a given
	load comes from a Limited_With_Clause.

	* lib-load.adb (From_Limited_With_Chain): New predicate to determine
	whether a potential circularity is harmless, because it includes units
	loaded through a limited_with clause. Extends previous treatment which
	did not handle properly arbitrary combinations of limited and
	non-limited clauses.

From-SVN: r103861
This commit is contained in:
Ed Schonberg 2005-09-05 09:53:24 +02:00 committed by Arnaud Charlet
parent 0f7164706b
commit 2f1b20a916
4 changed files with 284 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

385
gcc/ada/exp_ch6.adb
View File

@ -34,7 +34,6 @@ with Exp_Ch2; use Exp_Ch2;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
@ -172,10 +171,10 @@ package body Exp_Ch6 is
and then In_Open_Scopes (Scope (Etype (Typ)))
and then Typ = Base_Type (Typ)
then
-- Subp overrides an inherited private operation if there is
-- an inherited operation with a different name than Subp (see
-- Derive_Subprogram) whose Alias is a hidden subprogram with
-- the same name as Subp.
-- Subp overrides an inherited private operation if there is an
-- inherited operation with a different name than Subp (see
-- Derive_Subprogram) whose Alias is a hidden subprogram with the
-- same name as Subp.
Op_Elmt := First_Elmt (Op_List);
while Present (Op_Elmt) loop
@ -211,12 +210,12 @@ package body Exp_Ch6 is
-- List of recursive calls in body of procedure
Shad_List : constant Elist_Id := New_Elmt_List;
-- List of entity id's for entities created to capture the
-- value of referenced globals on entry to the procedure.
-- List of entity id's for entities created to capture the value of
-- referenced globals on entry to the procedure.
Scop : constant Uint := Scope_Depth (Spec);
-- This is used to record the scope depth of the current
-- procedure, so that we can identify global references.
-- This is used to record the scope depth of the current procedure, so
-- that we can identify global references.
Max_Vars : constant := 4;
-- Do not test more than four global variables
@ -359,9 +358,9 @@ package body Exp_Ch6 is
-- Start of processing for Detect_Infinite_Recursion
begin
-- Do not attempt detection in No_Implicit_Conditional mode,
-- since we won't be able to generate the code to handle the
-- recursion in any case.
-- Do not attempt detection in No_Implicit_Conditional mode, since we
-- won't be able to generate the code to handle the recursion in any
-- case.
if Restriction_Active (No_Implicit_Conditionals) then
return;
@ -372,9 +371,9 @@ package body Exp_Ch6 is
if Traverse_Body (N) = Abandon then
return;
-- We must have a call, since Has_Recursive_Call was set. If not
-- just ignore (this is only an error check, so if we have a funny
-- situation, due to bugs or errors, we do not want to bomb!)
-- We must have a call, since Has_Recursive_Call was set. If not just
-- ignore (this is only an error check, so if we have a funny situation,
-- due to bugs or errors, we do not want to bomb!)
elsif Is_Empty_Elmt_List (Call_List) then
return;
@ -382,15 +381,15 @@ package body Exp_Ch6 is
-- Here is the case where we detect recursion at compile time
-- Push our current scope for analyzing the declarations and
-- code that we will insert for the checking.
-- Push our current scope for analyzing the declarations and code that
-- we will insert for the checking.
New_Scope (Spec);
-- This loop builds temporary variables for each of the
-- referenced globals, so that at the end of the loop the
-- list Shad_List contains these temporaries in one-to-one
-- correspondence with the elements in Var_List.
-- This loop builds temporary variables for each of the referenced
-- globals, so that at the end of the loop the list Shad_List contains
-- these temporaries in one-to-one correspondence with the elements in
-- Var_List.
Last := Empty;
Elm := First_Elmt (Var_List);
@ -401,10 +400,10 @@ package body Exp_Ch6 is
Chars => New_Internal_Name ('S'));
Append_Elmt (Ent, Shad_List);
-- Insert a declaration for this temporary at the start of
-- the declarations for the procedure. The temporaries are
-- declared as constant objects initialized to the current
-- values of the corresponding temporaries.
-- Insert a declaration for this temporary at the start of the
-- declarations for the procedure. The temporaries are declared as
-- constant objects initialized to the current values of the
-- corresponding temporaries.
Decl :=
Make_Object_Declaration (Loc,
@ -940,7 +939,6 @@ package body Exp_Ch6 is
procedure Reset_Packed_Prefix is
Pfx : Node_Id := Actual;
begin
loop
Set_Analyzed (Pfx, False);
@ -953,11 +951,10 @@ package body Exp_Ch6 is
-- Start of processing for Expand_Actuals
begin
Formal := First_Formal (Subp);
Actual := First_Actual (N);
Post_Call := New_List;
Formal := First_Formal (Subp);
Actual := First_Actual (N);
while Present (Formal) loop
E_Formal := Etype (Formal);
@ -1155,10 +1152,9 @@ package body Exp_Ch6 is
if not Is_Empty_List (Post_Call) then
-- If call is not a list member, it must be the triggering
-- statement of a triggering alternative or an entry call
-- alternative, and we can add the post call stuff to the
-- corresponding statement list.
-- If call is not a list member, it must be the triggering statement
-- of a triggering alternative or an entry call alternative, and we
-- can add the post call stuff to the corresponding statement list.
if not Is_List_Member (N) then
declare
@ -1219,22 +1215,27 @@ package body Exp_Ch6 is
Actual : Node_Id;
Formal : Entity_Id;
Prev : Node_Id := Empty;
Prev_Orig : Node_Id;
Prev_Orig : Node_Id;
-- Original node for an actual, which may have been rewritten. If the
-- actual is a function call that has been transformed from a selected
-- component, the original node is unanalyzed. Otherwise, it carries
-- semantic information used to generate additional actuals.
Scop : Entity_Id;
Extra_Actuals : List_Id := No_List;
Cond : Node_Id;
CW_Interface_Formals_Present : Boolean := False;
procedure Add_Actual_Parameter (Insert_Param : Node_Id);
-- Adds one entry to the end of the actual parameter list. Used for
-- default parameters and for extra actuals (for Extra_Formals).
-- The argument is an N_Parameter_Association node.
-- default parameters and for extra actuals (for Extra_Formals). The
-- argument is an N_Parameter_Association node.
procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
-- Adds an extra actual to the list of extra actuals. Expr
-- is the expression for the value of the actual, EF is the
-- entity for the extra formal.
-- Adds an extra actual to the list of extra actuals. Expr is the
-- expression for the value of the actual, EF is the entity for the
-- extra formal.
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from a non-tagged formal derived
@ -1324,8 +1325,8 @@ package body Exp_Ch6 is
if Nkind (Parent (S)) /= N_Full_Type_Declaration
or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
or else Nkind (Type_Definition (Original_Node (Parent (S))))
/= N_Derived_Type_Definition
or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
N_Derived_Type_Definition
or else not In_Instance
then
return Empty;
@ -1353,31 +1354,29 @@ package body Exp_Ch6 is
Gen_Par := Generic_Parent_Type (Parent (Par));
end if;
-- If the generic parent type is still the generic type, this
-- is a private formal, not a derived formal, and there are no
-- operations inherited from the formal.
-- If the generic parent type is still the generic type, this is a
-- private formal, not a derived formal, and there are no operations
-- inherited from the formal.
if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
return Empty;
end if;
Gen_Prim := Collect_Primitive_Operations (Gen_Par);
Elmt := First_Elmt (Gen_Prim);
Elmt := First_Elmt (Gen_Prim);
while Present (Elmt) loop
if Chars (Node (Elmt)) = Chars (S) then
declare
F1 : Entity_Id;
F2 : Entity_Id;
begin
begin
F1 := First_Formal (S);
F2 := First_Formal (Node (Elmt));
while Present (F1)
and then Present (F2)
loop
if Etype (F1) = Etype (F2)
or else Etype (F2) = Gen_Par
then
@ -1448,7 +1447,8 @@ package body Exp_Ch6 is
begin
-- The case we catch is where the first argument is obtained
-- using the Identity attribute (which must always be non-null)
-- using the Identity attribute (which must always be
-- non-null).
if Nkind (FA) = N_Attribute_Reference
and then Attribute_Name (FA) = Name_Identity
@ -1490,8 +1490,14 @@ package body Exp_Ch6 is
Prev := Actual;
Prev_Orig := Original_Node (Prev);
if not Analyzed (Prev_Orig)
and then Nkind (Actual) = N_Function_Call
then
Prev_Orig := Prev;
end if;
-- Ada 2005 (AI-251): Check if any formal is a class-wide interface
-- to expand it in a further round
-- to expand it in a further round.
CW_Interface_Formals_Present :=
CW_Interface_Formals_Present
@ -1539,13 +1545,13 @@ package body Exp_Ch6 is
-- test applies to the actual, not the target type.
declare
Act_Prev : Node_Id := Prev;
Act_Prev : Node_Id;
begin
-- Test for unchecked conversions as well, which can
-- occur as out parameter actuals on calls to stream
-- procedures.
-- Test for unchecked conversions as well, which can occur
-- as out parameter actuals on calls to stream procedures.
Act_Prev := Prev;
while Nkind (Act_Prev) = N_Type_Conversion
or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
loop
@ -1669,55 +1675,59 @@ package body Exp_Ch6 is
end if;
end if;
-- Perform the check of 4.6(49) that prevents a null value
-- from being passed as an actual to an access parameter.
-- Note that the check is elided in the common cases of
-- passing an access attribute or access parameter as an
-- actual. Also, we currently don't enforce this check for
-- expander-generated actuals and when -gnatdj is set.
-- Perform the check of 4.6(49) that prevents a null value from being
-- passed as an actual to an access parameter. Note that the check is
-- elided in the common cases of passing an access attribute or
-- access parameter as an actual. Also, we currently don't enforce
-- this check for expander-generated actuals and when -gnatdj is set.
if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
or else Access_Checks_Suppressed (Subp)
then
null;
if Ada_Version >= Ada_05 then
elsif Debug_Flag_J then
null;
-- Ada 2005 (AI-231): Check null-excluding access types
elsif not Comes_From_Source (Prev) then
null;
if Is_Access_Type (Etype (Formal))
and then Can_Never_Be_Null (Etype (Formal))
and then Nkind (Prev) /= N_Raise_Constraint_Error
and then (Nkind (Prev) = N_Null
or else not Can_Never_Be_Null (Etype (Prev)))
then
Install_Null_Excluding_Check (Prev);
end if;
elsif Is_Entity_Name (Prev)
and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
then
null;
-- Ada_Version < Ada_05
elsif Nkind (Prev) = N_Allocator
or else Nkind (Prev) = N_Attribute_Reference
then
null;
else
if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
or else Access_Checks_Suppressed (Subp)
then
null;
-- Suppress null checks when passing to access parameters
-- of Java subprograms. (Should this be done for other
-- foreign conventions as well ???)
elsif Debug_Flag_J then
null;
elsif Convention (Subp) = Convention_Java then
null;
elsif not Comes_From_Source (Prev) then
null;
-- Ada 2005 (AI-231): do not force the check in case of Ada 2005
-- unless it is a null-excluding type
elsif Is_Entity_Name (Prev)
and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
then
null;
elsif Ada_Version < Ada_05
or else Can_Never_Be_Null (Etype (Prev))
then
Cond :=
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Prev),
Right_Opnd => Make_Null (Loc));
Insert_Action (Prev,
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Access_Parameter_Is_Null));
elsif Nkind (Prev) = N_Allocator
or else Nkind (Prev) = N_Attribute_Reference
then
null;
-- Suppress null checks when passing to access parameters of Java
-- subprograms. (Should this be done for other foreign conventions
-- as well ???)
elsif Convention (Subp) = Convention_Java then
null;
else
Install_Null_Excluding_Check (Prev);
end if;
end if;
-- Perform appropriate validity checks on parameters that
@ -1974,7 +1984,6 @@ package body Exp_Ch6 is
or else Is_Generic_Instance (Parent_Subp)
then
while Present (Formal) loop
if Etype (Formal) /= Etype (Parent_Formal)
and then Is_Scalar_Type (Etype (Formal))
and then Ekind (Formal) = E_In_Parameter
@ -1989,8 +1998,8 @@ package body Exp_Ch6 is
Enable_Range_Check (Actual);
elsif Is_Access_Type (Etype (Formal))
and then Base_Type (Etype (Parent_Formal))
/= Base_Type (Etype (Actual))
and then Base_Type (Etype (Parent_Formal)) /=
Base_Type (Etype (Actual))
then
if Ekind (Formal) /= E_In_Parameter then
Rewrite (Actual,
@ -2161,9 +2170,10 @@ package body Exp_Ch6 is
--------------------------
function In_Unfrozen_Instance return Boolean is
S : Entity_Id := Scop;
S : Entity_Id;
begin
S := Scop;
while Present (S)
and then S /= Standard_Standard
loop
@ -2183,10 +2193,12 @@ package body Exp_Ch6 is
-- Start of processing for Inlined_Subprogram
begin
-- Verify that the body to inline has already been seen,
-- and that if the body is in the current unit the inlining
-- does not occur earlier. This avoids order-of-elaboration
-- problems in gigi.
-- Verify that the body to inline has already been seen, and
-- that if the body is in the current unit the inlining does
-- not occur earlier. This avoids order-of-elaboration problems
-- in the back end.
-- This should be documented in sinfo/einfo ???
if No (Spec)
or else Nkind (Spec) /= N_Subprogram_Declaration
@ -2683,15 +2695,14 @@ package body Exp_Ch6 is
Original_Assignment : constant Node_Id := Parent (N);
begin
-- Preserve the original assignment node to keep the
-- complete assignment subtree consistent enough for
-- Analyze_Assignment to proceed (specifically, the
-- original Lhs node must still have an assignment
-- statement as its parent).
-- Preserve the original assignment node to keep the complete
-- assignment subtree consistent enough for Analyze_Assignment
-- to proceed (specifically, the original Lhs node must still
-- have an assignment statement as its parent).
-- We cannot rely on Original_Node to go back from the
-- block node to the assignment node, because the
-- assignment might already be a rewrite substitution.
-- We cannot rely on Original_Node to go back from the block
-- node to the assignment node, because the assignment might
-- already be a rewrite substitution.
Discard_Node (Relocate_Node (Original_Assignment));
Rewrite (Original_Assignment, Blk);
@ -2741,8 +2752,7 @@ package body Exp_Ch6 is
if Nkind (N) = N_Identifier
and then Present (Entity (N))
-- The original node's entity points to the one in the
-- copied body.
-- Original node's entity points to the one in the copied body
and then Nkind (Entity (N)) = N_Identifier
and then Present (Entity (Entity (N)))
@ -2781,8 +2791,8 @@ package body Exp_Ch6 is
-- Check for special case of To_Address call, and if so, just do an
-- unchecked conversion instead of expanding the call. Not only is this
-- more efficient, but it also avoids problem with order of elaboration
-- when address clauses are inlined (address expr elaborated at wrong
-- point).
-- when address clauses are inlined (address expression elaborated at
-- wrong point).
if Subp = RTE (RE_To_Address) then
Rewrite (N,
@ -2848,15 +2858,14 @@ package body Exp_Ch6 is
Ret_Type := Etype (Subp);
end if;
F := First_Formal (Subp);
A := First_Actual (N);
-- Create temporaries for the actuals that are expressions, or that
-- are scalars and require copying to preserve semantics.
F := First_Formal (Subp);
A := First_Actual (N);
while Present (F) loop
if Present (Renamed_Object (F)) then
Error_Msg_N (" cannot inline call to recursive subprogram", N);
Error_Msg_N ("cannot inline call to recursive subprogram", N);
return;
end if;
@ -3061,7 +3070,6 @@ package body Exp_Ch6 is
-- Cleanup mapping between formals and actuals for other expansions
F := First_Formal (Subp);
while Present (F) loop
Set_Renamed_Object (F, Empty);
Next_Formal (F);
@ -3090,7 +3098,7 @@ package body Exp_Ch6 is
---------------------------
function Returned_By_Reference return Boolean is
S : Entity_Id := Current_Scope;
S : Entity_Id;
begin
if Is_Return_By_Reference_Type (Typ) then
@ -3104,6 +3112,7 @@ package body Exp_Ch6 is
-- Verify that the return type of the enclosing function has the
-- same constrained status as that of the expression.
S := Current_Scope;
while Ekind (S) /= E_Function loop
S := Scope (S);
end loop;
@ -3202,9 +3211,9 @@ package body Exp_Ch6 is
-- object is not classwide.
Proc := Entity (Name (Parent (N)));
F := First_Formal (Proc);
A := First_Actual (Parent (N));
while A /= N loop
Next_Formal (F);
Next_Actual (A);
@ -3535,9 +3544,10 @@ package body Exp_Ch6 is
and then not Has_Pragma_Pure_Function (Spec_Id)
then
declare
F : Entity_Id := First_Formal (Spec_Id);
F : Entity_Id;
begin
F := First_Formal (Spec_Id);
while Present (F) loop
if Is_Descendent_Of_Address (Etype (F)) then
Set_Is_Pure (Spec_Id, False);
@ -3558,7 +3568,7 @@ package body Exp_Ch6 is
if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
declare
F : Entity_Id := First_Formal (Spec_Id);
F : Entity_Id;
V : constant Boolean := Validity_Checks_On;
begin
@ -3570,6 +3580,7 @@ package body Exp_Ch6 is
-- Loop through formals
F := First_Formal (Spec_Id);
while Present (F) loop
if Is_Scalar_Type (Etype (F))
and then Ekind (F) = E_Out_Parameter
@ -3589,9 +3600,9 @@ package body Exp_Ch6 is
Scop := Scope (Spec_Id);
-- Add discriminal renamings to protected subprograms.
-- Install new discriminals for expansion of the next
-- subprogram of this protected type, if any.
-- Add discriminal renamings to protected subprograms. Install new
-- discriminals for expansion of the next subprogram of this protected
-- type, if any.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
@ -3602,9 +3613,8 @@ package body Exp_Ch6 is
Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
-- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand
-- references to private data objects and discriminants,
-- respectively.
-- operation body to be expanded. These are used to expand references
-- to private data objects and discriminants, respectively.
Next_Op := Next_Protected_Operation (N);
@ -3633,7 +3643,7 @@ package body Exp_Ch6 is
end if;
-- Returns_By_Ref flag is normally set when the subprogram is frozen
-- but subprograms with no specs are not frozen
-- but subprograms with no specs are not frozen.
declare
Typ : constant Entity_Id := Etype (Spec_Id);
@ -3665,7 +3675,6 @@ package body Exp_Ch6 is
if Present (Exception_Handlers (H)) then
Except_H := First_Non_Pragma (Exception_Handlers (H));
while Present (Except_H) loop
Add_Return (Statements (Except_H));
Next_Non_Pragma (Except_H);
@ -3742,7 +3751,6 @@ package body Exp_Ch6 is
begin
Formal := First_Formal (Spec_Id);
while Present (Formal) loop
Floc := Sloc (Formal);
@ -3769,18 +3777,6 @@ package body Exp_Ch6 is
Expand_Thread_Body;
end if;
-- If the subprogram does not have pending instantiations, then we
-- must generate the subprogram descriptor now, since the code for
-- the subprogram is complete, and this is our last chance. However
-- if there are pending instantiations, then the code is not
-- complete, and we will delay the generation.
if Is_Subprogram (Spec_Id)
and then not Delay_Subprogram_Descriptors (Spec_Id)
then
Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id);
end if;
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
@ -3818,8 +3814,8 @@ package body Exp_Ch6 is
Prot_Id : Entity_Id;
begin
-- Deal with case of protected subprogram. Do not generate
-- protected operation if operation is flagged as eliminated.
-- Deal with case of protected subprogram. Do not generate protected
-- operation if operation is flagged as eliminated.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
@ -3833,7 +3829,7 @@ package body Exp_Ch6 is
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(N, Scop, Unprotected => True));
(N, Scop, Unprotected_Mode));
-- The protected subprogram is declared outside of the protected
-- body. Given that the body has frozen all entities so far, we
@ -3907,18 +3903,16 @@ package body Exp_Ch6 is
Rec := Make_Identifier (Loc, Name_uObject);
Set_Etype (Rec, Corresponding_Record_Type (Scop));
-- Find enclosing protected operation, and retrieve its first
-- parameter, which denotes the enclosing protected object.
-- If the enclosing operation is an entry, we are immediately
-- within the protected body, and we can retrieve the object
-- from the service entries procedure. A barrier function has
-- has the same signature as an entry. A barrier function is
-- compiled within the protected object, but unlike protected
-- operations its never needs locks, so that its protected body
-- subprogram points to itself.
-- Find enclosing protected operation, and retrieve its first parameter,
-- which denotes the enclosing protected object. If the enclosing
-- operation is an entry, we are immediately within the protected body,
-- and we can retrieve the object from the service entries procedure. A
-- barrier function has has the same signature as an entry. A barrier
-- function is compiled within the protected object, but unlike
-- protected operations its never needs locks, so that its protected
-- body subprogram points to itself.
Proc := Current_Scope;
while Present (Proc)
and then Scope (Proc) /= Scop
loop
@ -3946,17 +3940,16 @@ package body Exp_Ch6 is
Set_Entity (Rec, Param);
-- Rec is a reference to an entity which will not be in scope
-- when the call is reanalyzed, and needs no further analysis.
-- Rec is a reference to an entity which will not be in scope when
-- the call is reanalyzed, and needs no further analysis.
Set_Analyzed (Rec);
else
-- Entry or barrier function for entry body.
-- The first parameter of the entry body procedure is a
-- pointer to the object. We create a local variable
-- of the proper type, duplicating what is done to define
-- _object later on.
-- Entry or barrier function for entry body. The first parameter of
-- the entry body procedure is pointer to the object. We create a
-- local variable of the proper type, duplicating what is done to
-- define _object later on.
declare
Decls : List_Id;
@ -3982,9 +3975,8 @@ package body Exp_Ch6 is
Unchecked_Convert_To (Obj_Ptr,
New_Occurrence_Of (Param, Loc)));
-- Analyze new actual. Other actuals in calls are already
-- analyzed and the list of actuals is not renalyzed after
-- rewriting.
-- Analyze new actual. Other actuals in calls are already analyzed
-- and the list of actuals is not renalyzed after rewriting.
Set_Parent (Rec, N);
Analyze (Rec);
@ -4065,7 +4057,7 @@ package body Exp_Ch6 is
procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
-- (Ada 2005): Check if the primitive E covers some interface already
-- implemented by some ancestor of the tagged-type associated with E
-- implemented by some ancestor of the tagged-type associated with E.
procedure Register_Interface_DT_Entry
(Prim : Entity_Id;
@ -4114,29 +4106,56 @@ package body Exp_Ch6 is
while Present (Elmt) loop
Prim_Op := Node (Elmt);
if DT_Position (Prim_Op) = DT_Position (E)
if Chars (Prim_Op) = Chars (E)
and then Type_Conformant
(New_Id => Prim_Op,
Old_Id => E,
Skip_Controlling_Formals => True)
and then DT_Position (Prim_Op) = DT_Position (E)
and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
and then not Present (Abstract_Interface_Alias (Prim_Op))
then
if Overriden_Op /= Empty then
raise Program_Error;
end if;
if Overriden_Op = Empty then
Overriden_Op := Prim_Op;
Overriden_Op := Prim_Op;
-- Additional check to ensure that if two candidates have
-- been found then they refer to the same subprogram.
else
declare
A1 : Entity_Id;
A2 : Entity_Id;
begin
A1 := Overriden_Op;
while Present (Alias (A1)) loop
A1 := Alias (A1);
end loop;
A2 := Prim_Op;
while Present (Alias (A2)) loop
A2 := Alias (A2);
end loop;
if A1 /= A2 then
raise Program_Error;
end if;
end;
end if;
end if;
Next_Elmt (Elmt);
end loop;
-- if not found this is the first overriding of some
-- abstract interface
-- If not found this is the first overriding of some abstract
-- interface.
if Overriden_Op /= Empty then
Elmt := First_Elmt (Primitive_Operations (Typ));
-- Find the entries associated with interfaces that are
-- alias of this primitive operation in the ancestor
-- alias of this primitive operation in the ancestor.
Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Elmt) loop
Prim_Op := Node (Elmt);
@ -4178,7 +4197,7 @@ package body Exp_Ch6 is
Iface => Iface_Typ);
-- Generate the code of the thunk only when this primitive
-- operation is associated with a secondary dispatch table
-- operation is associated with a secondary dispatch table.
if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
Thunk_Id := Make_Defining_Identifier (Loc,
@ -4188,7 +4207,7 @@ package body Exp_Ch6 is
(N => Prim,
Thunk_Alias => Alias (Prim),
Thunk_Id => Thunk_Id,
Iface_Tag => Iface_Tag);
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk);
@ -4238,7 +4257,7 @@ package body Exp_Ch6 is
(N => Ancestor_Iface_Prim,
Thunk_Alias => Prim_Op,
Thunk_Id => Thunk_Id,
Iface_Tag => Iface_Tag);
Thunk_Tag => Iface_Tag);
Insert_After (N, New_Thunk);
@ -4279,7 +4298,7 @@ package body Exp_Ch6 is
else
-- Ada 2005 (AI-251): Check if this entry corresponds with
-- a subprogram that covers an abstract interface type
-- a subprogram that covers an abstract interface type.
if Present (Abstract_Interface_Alias (E)) then
Register_Interface_DT_Entry (E);
@ -4296,7 +4315,7 @@ package body Exp_Ch6 is
-- Mark functions that return by reference. Note that it cannot be
-- part of the normal semantic analysis of the spec since the
-- underlying returned type may not be known yet (for private types)
-- underlying returned type may not be known yet (for private types).
declare
Typ : constant Entity_Id := Etype (E);

32
gcc/ada/exp_dbug.ads
View File

@ -89,7 +89,7 @@ package Exp_Dbug is
-- x
-- y.z
-- The separating dots are translated into double underscores.
-- The separating dots are translated into double underscores
-----------------------------
-- Handling of Overloading --
@ -385,6 +385,28 @@ package Exp_Dbug is
-- lock_update1sE
-- lock_udpate2sB
-- If the protected type implements at least one interface, the
-- following additional operations are created:
-- lock_get
-- lock_set
-- These operations are used to ensure overriding of interface level
-- subprograms and proper dispatching on interface class-wide objects.
-- The bodies of these operations contain calls to their respective
-- protected versions:
-- function lock_get return Integer is
-- begin
-- return lock_getP;
-- end lock_get;
-- procedure lock_set (X : Integer) is
-- begin
-- lock_setP (X);
-- end lock_set;
----------------------------------------------------
-- Conversion between Entities and External Names --
----------------------------------------------------
@ -686,9 +708,9 @@ package Exp_Dbug is
-- follows. In this description, let P represent the current
-- bit position in the record.
-- 1. Initialize P to 0.
-- 1. Initialize P to 0
-- 2. For each field in the record,
-- 2. For each field in the record:
-- 2a. If an alignment is given (see below), then round P
-- up, if needed, to the next multiple of that alignment.
@ -697,7 +719,7 @@ package Exp_Dbug is
-- amount (that is, treat it as an offset from the end of the
-- preceding record).
-- 2c. Assign P as the actual position of the field.
-- 2c. Assign P as the actual position of the field
-- 2d. Compute the length, L, of the represented field (see below)
-- and compute P'=P+L. Unless the field represents a variant part
@ -963,7 +985,7 @@ package Exp_Dbug is
-- name of the parent unit, to disambiguate child units with the same
-- simple name and (of necessity) different parents.
-- Note: subprogram renamings are not encoded at the present time.
-- Note: subprogram renamings are not encoded at the present time
-- The type is an enumeration type with a single enumeration literal
-- that is an identifier which describes the renamed variable.

44
gcc/ada/lib-load.adb
View File

@ -53,6 +53,11 @@ package body Lib.Load is
-- Local Subprograms --
-----------------------
function From_Limited_With_Chain (Lim : Boolean) return Boolean;
-- Check whether a possible circular dependence includes units that
-- have been loaded through limited_with clauses, in which case there
-- is no real circularity.
function Spec_Is_Irrelevant
(Spec_Unit : Unit_Number_Type;
Body_Unit : Unit_Number_Type) return Boolean;
@ -165,6 +170,30 @@ package body Lib.Load is
return Unum;
end Create_Dummy_Package_Unit;
-----------------------------
-- From_Limited_With_Chain --
-----------------------------
function From_Limited_With_Chain (Lim : Boolean) return Boolean is
begin
-- True if the current load operation is through a limited_with clause
if Lim then
return True;
-- Examine the Load_Stack to locate any previous Limited_with clause
elsif Load_Stack.Last - 1 > Load_Stack.First then
for U in Load_Stack.First .. Load_Stack.Last - 1 loop
if Load_Stack.Table (U).From_Limited_With then
return True;
end if;
end loop;
end if;
return False;
end From_Limited_With_Chain;
----------------
-- Initialize --
----------------
@ -193,7 +222,7 @@ package body Lib.Load is
begin
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := Main_Unit;
Load_Stack.Table (Load_Stack.Last) := (Main_Unit, False);
-- Initialize unit table entry for Main_Unit. Note that we don't know
-- the unit name yet, that gets filled in when the parser parses the
@ -465,10 +494,11 @@ package body Lib.Load is
end loop;
end if;
-- If we are proceeding with load, then make load stack entry
-- If we are proceeding with load, then make load stack entry,
-- and indicate the kind of with_clause responsible for the load.
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := Unum;
Load_Stack.Table (Load_Stack.Last) := (Unum, From_Limited_With);
-- Case of entry already in table
@ -489,7 +519,7 @@ package body Lib.Load is
or else Acts_As_Spec (Units.Table (Unum).Cunit))
and then (Nkind (Error_Node) /= N_With_Clause
or else not Limited_Present (Error_Node))
and then not From_Limited_With
and then not From_Limited_With_Chain (From_Limited_With)
then
if Debug_Flag_L then
Write_Str (" circular dependency encountered");
@ -733,8 +763,10 @@ package body Lib.Load is
if Load_Stack.Last - 1 > Load_Stack.First then
for U in Load_Stack.First .. Load_Stack.Last - 1 loop
Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
Error_Msg_Unit_1 :=
Unit_Name (Load_Stack.Table (U).Unit_Number);
Error_Msg_Unit_2 :=
Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
Error_Msg ("$ depends on $!", Load_Msg_Sloc);
end loop;
end if;

32
gcc/ada/lib.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -239,11 +239,6 @@ package Lib is
-- Main_Unit is a body with a separate spec, in which case it is the
-- entity for the spec.
Unit_Exception_Table_Present : Boolean;
-- Set true if a unit exception table is present for the unit (i.e.
-- zero cost exception handling is active and there is at least one
-- subprogram in the extended unit).
-----------------
-- Units Table --
-----------------
@ -623,7 +618,7 @@ package Lib is
function Generic_Separately_Compiled
(Sfile : File_Name_Type) return Boolean;
-- Same as the previous function, but works directly on a unit file name.
-- Same as the previous function, but works directly on a unit file name
private
pragma Inline (Cunit);
@ -722,16 +717,23 @@ private
type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type;
-- Type to hold list of indirect references to unit number table
-- The Load_Stack table contains a list of unit numbers (indexes into the
-- unit table) of units being loaded on a single dependency chain. The
-- First entry is the main unit. The second entry, if present is a unit
-- on which the first unit depends, etc. This stack is used to generate
-- error messages showing the dependency chain if a file is not found.
-- The Load function makes an entry in this table when it is called, and
-- removes the entry just before it returns.
type Load_Stack_Entry is record
Unit_Number : Unit_Number_Type;
From_Limited_With : Boolean;
end record;
-- The Load_Stack table contains a list of unit numbers (indices into the
-- unit table) of units being loaded on a single dependency chain, and a
-- flag to indicate whether this unit is loaded through a limited_with
-- clause. The First entry is the main unit. The second entry, if present
-- is a unit on which the first unit depends, etc. This stack is used to
-- generate error messages showing the dependency chain if a file is not
-- found, or whether a true circular dependency exists. The Load_Unit
-- function makes an entry in this table when it is called, and removes
-- the entry just before it returns.
package Load_Stack is new Table.Table (
Table_Component_Type => Unit_Number_Type,
Table_Component_Type => Load_Stack_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 0,
Table_Initial => Alloc.Load_Stack_Initial,