-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
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;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-- we have an infinite recursion.
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
- -- For each actual of an in-out parameter which is a numeric conversion
- -- of the form T(A), where A denotes a variable, we insert the declaration:
+ -- For each actual of an in-out or out parameter which is a numeric
+ -- (view) conversion of the form T (A), where A denotes a variable,
+ -- we insert the declaration:
--
- -- Temp : T := T (A);
+ -- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- For all parameter modes, actuals that denote components and slices
-- of packed arrays are expanded into suitable temporaries.
+ --
+ -- For non-scalar objects that are possibly unaligned, add call by copy
+ -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
procedure Expand_Inlined_Call
(N : Node_Id;
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
-- 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
-- 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;
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;
-- 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);
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,
-- also takes care of any constraint checks required for the type
-- conversion case (on both the way in and the way out).
- procedure Add_Packed_Call_By_Copy_Code;
- -- This is used when the actual involves a reference to an element
- -- of a packed array, where we can appropriately use a simpler
- -- approach than the full call by copy code. We just copy the value
- -- in and out of an appropriate temporary.
+ procedure Add_Simple_Call_By_Copy_Code;
+ -- This is similar to the above, but is used in cases where we know
+ -- that all that is needed is to simply create a temporary and copy
+ -- the value in and out of the temporary.
procedure Check_Fortran_Logical;
-- A value of type Logical that is passed through a formal parameter
-- representation as True. We assume that .FALSE. = False = 0.
-- What about functions that return a logical type ???
+ function Is_Legal_Copy return Boolean;
+ -- Check that an actual can be copied before generating the temporary
+ -- to be used in the call. If the actual is of a by_reference type then
+ -- the program is illegal (this can only happen in the presence of
+ -- rep. clauses that force an incorrect alignment). If the formal is
+ -- a by_reference parameter imposed by a DEC pragma, emit a warning to
+ -- the effect that this might lead to unaligned arguments.
+
function Make_Var (Actual : Node_Id) return Entity_Id;
-- Returns an entity that refers to the given actual parameter,
-- Actual (not including any type conversion). If Actual is an
Expr : Node_Id;
Init : Node_Id;
Temp : Entity_Id;
- Indic : Node_Id := New_Occurrence_Of (Etype (Formal), Loc);
+ Indic : Node_Id;
Var : Entity_Id;
F_Typ : constant Entity_Id := Etype (Formal);
V_Typ : Entity_Id;
Crep : Boolean;
begin
+ if not Is_Legal_Copy then
+ return;
+ end if;
+
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ -- Use formal type for temp, unless formal type is an unconstrained
+ -- array, in which case we don't have to worry about bounds checks,
+ -- and we use the actual type, since that has appropriate bounds.
+
+ if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
+ Indic := New_Occurrence_Of (Etype (Actual), Loc);
+ else
+ Indic := New_Occurrence_Of (Etype (Formal), Loc);
+ end if;
+
if Nkind (Actual) = N_Type_Conversion then
V_Typ := Etype (Expression (Actual));
then
-- Actual is a one-dimensional array or slice, and the type
-- requires no initialization. Create a temporary of the
- -- right size, but do copy actual into it (optimization).
+ -- right size, but do not copy actual into it (optimization).
Init := Empty;
Indic :=
Is_Bit_Packed_Array (Etype (Expression (Actual))))
then
if Conversion_OK (Actual) then
- Init :=
- OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
+ Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
- Init :=
- Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
+ Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_In_Parameter then
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Indic,
- Expression => Init);
+ Expression => Init);
Set_Assignment_OK (N_Node);
Insert_Action (N, N_Node);
-- Processing for OUT or IN OUT parameter
else
+ -- Kill current value indications for the temporary variable we
+ -- created, since we just passed it as an OUT parameter.
+
+ Kill_Current_Values (Temp);
+
-- If type conversion, use reverse conversion on exit
if Nkind (Actual) = N_Type_Conversion then
end Add_Call_By_Copy_Code;
----------------------------------
- -- Add_Packed_Call_By_Copy_Code --
+ -- Add_Simple_Call_By_Copy_Code --
----------------------------------
- procedure Add_Packed_Call_By_Copy_Code is
+ procedure Add_Simple_Call_By_Copy_Code is
Temp : Entity_Id;
+ Decl : Node_Id;
Incod : Node_Id;
Outcod : Node_Id;
Lhs : Node_Id;
Rhs : Node_Id;
+ Indic : Node_Id;
+ F_Typ : constant Entity_Id := Etype (Formal);
begin
- Reset_Packed_Prefix;
+ if not Is_Legal_Copy then
+ return;
+ end if;
+
+ -- Use formal type for temp, unless formal type is an unconstrained
+ -- array, in which case we don't have to worry about bounds checks,
+ -- and we use the actual type, since that has appropriate bounds.
+
+ if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
+ Indic := New_Occurrence_Of (Etype (Actual), Loc);
+ else
+ Indic := New_Occurrence_Of (Etype (Formal), Loc);
+ end if;
-- Prepare to generate code
+ Reset_Packed_Prefix;
+
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Incod := Relocate_Node (Actual);
Outcod := New_Copy_Tree (Incod);
-- Generate declaration of temporary variable, initializing it
- -- with the input parameter unless we have an OUT variable.
+ -- with the input parameter unless we have an OUT formal or
+ -- this is an initialization call.
+
+ -- If the formal is an out parameter with discriminants, the
+ -- discriminants must be captured even if the rest of the object
+ -- is in principle uninitialized, because the discriminants may
+ -- be read by the called subprogram.
if Ekind (Formal) = E_Out_Parameter then
Incod := Empty;
+
+ if Has_Discriminants (Etype (Formal)) then
+ Indic := New_Occurrence_Of (Etype (Actual), Loc);
+ end if;
+
+ elsif Inside_Init_Proc then
+
+ -- Could use a comment here to match comment below ???
+
+ if Nkind (Actual) /= N_Selected_Component
+ or else
+ not Has_Discriminant_Dependent_Constraint
+ (Entity (Selector_Name (Actual)))
+ then
+ Incod := Empty;
+
+ -- Otherwise, keep the component in order to generate the proper
+ -- actual subtype, that depends on enclosing discriminants.
+
+ else
+ null;
+ end if;
end if;
- Insert_Action (N,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Etype (Formal), Loc),
- Expression => Incod));
+ Object_Definition => Indic,
+ Expression => Incod);
+
+ if Inside_Init_Proc
+ and then No (Incod)
+ then
+ -- If the call is to initialize a component of a composite type,
+ -- and the component does not depend on discriminants, use the
+ -- actual type of the component. This is required in case the
+ -- component is constrained, because in general the formal of the
+ -- initialization procedure will be unconstrained. Note that if
+ -- the component being initialized is constrained by an enclosing
+ -- discriminant, the presence of the initialization in the
+ -- declaration will generate an expression for the actual subtype.
+
+ Set_No_Initialization (Decl);
+ Set_Object_Definition (Decl,
+ New_Occurrence_Of (Etype (Actual), Loc));
+ end if;
+
+ Insert_Action (N, Decl);
-- The actual is simply a reference to the temporary
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Rhs));
+ Set_Assignment_OK (Name (Last (Post_Call)));
end if;
- end Add_Packed_Call_By_Copy_Code;
+ end Add_Simple_Call_By_Copy_Code;
---------------------------
-- Check_Fortran_Logical --
end if;
end Check_Fortran_Logical;
+ -------------------
+ -- Is_Legal_Copy --
+ -------------------
+
+ function Is_Legal_Copy return Boolean is
+ begin
+ -- An attempt to copy a value of such a type can only occur if
+ -- representation clauses give the actual a misaligned address.
+
+ if Is_By_Reference_Type (Etype (Formal)) then
+ Error_Msg_N
+ ("misaligned actual cannot be passed by reference", Actual);
+ return False;
+
+ -- For users of Starlet, we assume that the specification of by-
+ -- reference mechanism is mandatory. This may lead to unligned
+ -- objects but at least for DEC legacy code it is known to work.
+ -- The warning will alert users of this code that a problem may
+ -- be lurking.
+
+ elsif Mechanism (Formal) = By_Reference
+ and then Is_Valued_Procedure (Scope (Formal))
+ then
+ Error_Msg_N
+ ("by_reference actual may be misaligned?", Actual);
+ return False;
+
+ else
+ return True;
+ end if;
+ end Is_Legal_Copy;
+
--------------
-- Make_Var --
--------------
procedure Reset_Packed_Prefix is
Pfx : Node_Id := Actual;
-
begin
loop
Set_Analyzed (Pfx, False);
-- 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);
-- [in] out parameters.
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Packed_Call_By_Copy_Code;
+ Add_Simple_Call_By_Copy_Code;
+
+ -- If a non-scalar actual is possibly unaligned, we need a copy
+
+ elsif Is_Possibly_Unaligned_Object (Actual)
+ and then not Represented_As_Scalar (Etype (Formal))
+ then
+ Add_Simple_Call_By_Copy_Code;
-- References to slices of bit packed arrays are expanded
then
Add_Call_By_Copy_Code;
+ -- If the actual is not a scalar and is marked for volatile
+ -- treatment, whereas the formal is not volatile, then pass
+ -- by copy unless it is a by-reference type.
+
elsif Is_Entity_Name (Actual)
and then Treat_As_Volatile (Entity (Actual))
+ and then not Is_By_Reference_Type (Etype (Actual))
and then not Is_Scalar_Type (Etype (Entity (Actual)))
and then not Treat_As_Volatile (E_Formal)
then
-- the special processing above for the OUT and IN OUT cases
-- could be performed. We could make the test in Exp_Ch4 more
-- complex and have it detect the parameter mode, but it is
- -- easier simply to handle all cases here.
+ -- easier simply to handle all cases here.)
if Nkind (Actual) = N_Indexed_Component
and then Is_Packed (Etype (Prefix (Actual)))
-- Is this really necessary in all cases???
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Packed_Call_By_Copy_Code;
+ Add_Simple_Call_By_Copy_Code;
+
+ -- If a non-scalar actual is possibly unaligned, we need a copy
+
+ elsif Is_Possibly_Unaligned_Object (Actual)
+ and then not Represented_As_Scalar (Etype (Formal))
+ then
+ Add_Simple_Call_By_Copy_Code;
-- Similarly, we have to expand slices of packed arrays here
-- because the result must be byte aligned.
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
end if;
end if;
- -- The call node itself is re-analyzed in Expand_Call.
+ -- The call node itself is re-analyzed in Expand_Call
end Expand_Actuals;
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
Set_First_Named_Actual (N, Actual_Expr);
if No (Prev) then
- if not Present (Parameter_Associations (N)) then
+ if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List);
Append (Insert_Param, Parameter_Associations (N));
end if;
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;
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
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
end if;
end if;
+ -- Ada 2005 (AI-345): We have a procedure call as a triggering
+ -- alternative in an asynchronous select or as an entry call in
+ -- a conditional or timed select. Check whether the procedure call
+ -- is a renaming of an entry and rewrite it as an entry call.
+
+ if Ada_Version >= Ada_05
+ and then Nkind (N) = N_Procedure_Call_Statement
+ and then
+ ((Nkind (Parent (N)) = N_Triggering_Alternative
+ and then Triggering_Statement (Parent (N)) = N)
+ or else
+ (Nkind (Parent (N)) = N_Entry_Call_Alternative
+ and then Entry_Call_Statement (Parent (N)) = N))
+ then
+ declare
+ Ren_Decl : Node_Id;
+ Ren_Root : Entity_Id := Subp;
+
+ begin
+ -- This may be a chain of renamings, find the root
+
+ if Present (Alias (Ren_Root)) then
+ Ren_Root := Alias (Ren_Root);
+ end if;
+
+ if Present (Original_Node (Parent (Parent (Ren_Root)))) then
+ Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
+
+ if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
+ Rewrite (N,
+ Make_Entry_Call_Statement (Loc,
+ Name =>
+ New_Copy_Tree (Name (Ren_Decl)),
+ Parameter_Associations =>
+ New_Copy_List_Tree (Parameter_Associations (N))));
+
+ return;
+ end if;
+ end if;
+ end;
+ end if;
+
-- First step, compute extra actuals, corresponding to any
-- Extra_Formals present. Note that we do not access Extra_Formals
-- directly, instead we simply note the presence of the extra
Prev := Actual;
Prev_Orig := Original_Node (Prev);
- -- Create possible extra actual for constrained case. Usually,
- -- the extra actual is of the form actual'constrained, but since
- -- this attribute is only available for unconstrained records,
- -- TRUE is expanded if the type of the formal happens to be
- -- constrained (for instance when this procedure is inherited
- -- from an unconstrained record to a constrained one) or if the
- -- actual has no discriminant (its type is constrained). An
- -- exception to this is the case of a private type without
- -- discriminants. In this case we pass FALSE because the
- -- object has underlying discriminants with defaults.
+ 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.
+
+ CW_Interface_Formals_Present :=
+ CW_Interface_Formals_Present
+ or else
+ (Ekind (Etype (Formal)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (Etype (Formal))))
+ or else
+ (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Is_Interface (Directly_Designated_Type
+ (Etype (Etype (Formal)))));
+
+ -- Create possible extra actual for constrained case. Usually, the
+ -- extra actual is of the form actual'constrained, but since this
+ -- attribute is only available for unconstrained records, TRUE is
+ -- expanded if the type of the formal happens to be constrained (for
+ -- instance when this procedure is inherited from an unconstrained
+ -- record to a constrained one) or if the actual has no discriminant
+ -- (its type is constrained). An exception to this is the case of a
+ -- private type without discriminants. In this case we pass FALSE
+ -- because the object has underlying discriminants with defaults.
if Present (Extra_Constrained (Formal)) then
if Ekind (Etype (Prev)) in Private_Kind
-- 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
Act_Prev := Expression (Act_Prev);
end loop;
- Add_Extra_Actual (
- Make_Attribute_Reference (Sloc (Prev),
- Prefix =>
- Duplicate_Subexpr_No_Checks
- (Act_Prev, Name_Req => True),
- Attribute_Name => Name_Constrained),
- Extra_Constrained (Formal));
+ -- If the expression is a conversion of a dereference,
+ -- this is internally generated code that manipulates
+ -- addresses, e.g. when building interface tables. No
+ -- check should occur in this case, and the discriminated
+ -- object is not directly a hand.
+
+ if not Comes_From_Source (Actual)
+ and then Nkind (Actual) = N_Unchecked_Type_Conversion
+ and then Nkind (Act_Prev) = N_Explicit_Dereference
+ then
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_False, Loc),
+ Extra_Constrained (Formal));
+
+ else
+ Add_Extra_Actual
+ (Make_Attribute_Reference (Sloc (Prev),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Act_Prev, Name_Req => True),
+ Attribute_Name => Name_Constrained),
+ Extra_Constrained (Formal));
+ end if;
end;
end if;
end if;
pragma Assert (Present (Parm_Ent));
if Present (Extra_Accessibility (Parm_Ent)) then
- Add_Extra_Actual (
- New_Occurrence_Of
- (Extra_Accessibility (Parm_Ent), Loc),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of
+ (Extra_Accessibility (Parm_Ent), Loc),
+ Extra_Accessibility (Formal));
-- If the actual access parameter does not have an
-- associated extra formal providing its scope level,
-- accessibility.
else
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Standard_Standard)),
+ Extra_Accessibility (Formal));
end if;
end;
-- level of the actual's access type.
else
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Type_Access_Level (Etype (Prev_Orig))),
+ Extra_Accessibility (Formal));
end if;
else
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
-- are entities.
if Validity_Checks_On then
- if Ekind (Formal) = E_In_Parameter
- and then Validity_Check_In_Params
+ if (Ekind (Formal) = E_In_Parameter
+ and then Validity_Check_In_Params)
+ or else
+ (Ekind (Formal) = E_In_Out_Parameter
+ and then Validity_Check_In_Out_Params)
then
-- If the actual is an indexed component of a packed
-- type, it has not been expanded yet. It will be
end if;
Ensure_Valid (Actual);
-
- elsif Ekind (Formal) = E_In_Out_Parameter
- and then Validity_Check_In_Out_Params
- then
- Ensure_Valid (Actual);
end if;
end if;
Check_Valid_Lvalue_Subscripts (Actual);
end if;
- -- Mark any scalar OUT parameter that is a simple variable
- -- as no longer known to be valid (unless the type is always
- -- valid). This reflects the fact that if an OUT parameter
- -- is never set in a procedure, then it can become invalid
- -- on return from the procedure.
+ -- Mark any scalar OUT parameter that is a simple variable as no
+ -- longer known to be valid (unless the type is always valid). This
+ -- reflects the fact that if an OUT parameter is never set in a
+ -- procedure, then it can become invalid on the procedure return.
if Ekind (Formal) = E_Out_Parameter
and then Is_Entity_Name (Actual)
Set_Is_Known_Valid (Entity (Actual), False);
end if;
- -- For an OUT or IN OUT parameter of an access type, if the
- -- actual is an entity, then it is no longer known to be non-null.
+ -- For an OUT or IN OUT parameter, if the actual is an entity, then
+ -- clear current values, since they can be clobbered. We are probably
+ -- doing this in more places than we need to, but better safe than
+ -- sorry when it comes to retaining bad current values!
if Ekind (Formal) /= E_In_Parameter
and then Is_Entity_Name (Actual)
- and then Is_Access_Type (Etype (Actual))
then
- Set_Is_Known_Non_Null (Entity (Actual), False);
+ Kill_Current_Values (Entity (Actual));
end if;
-- If the formal is class wide and the actual is an aggregate, force
Next_Formal (Formal);
end loop;
- -- If we are expanding a rhs of an assignement we need to check if
- -- tag propagation is needed. This code belongs theorically in Analyze
- -- Assignment but has to be done earlier (bottom-up) because the
- -- assignment might be transformed into a declaration for an uncons-
- -- trained value, if the expression is classwide.
+ -- If we are expanding a rhs of an assignment we need to check if tag
+ -- propagation is needed. You might expect this processing to be in
+ -- Analyze_Assignment but has to be done earlier (bottom-up) because the
+ -- assignment might be transformed to a declaration for an unconstrained
+ -- value if the expression is classwide.
if Nkind (N) = N_Function_Call
and then Is_Tag_Indeterminate (N)
end;
end if;
+ -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
+ -- it to point to the correct secondary virtual table
+
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then CW_Interface_Formals_Present
+ then
+ Expand_Interface_Actuals (N);
+ end if;
+
-- Deals with Dispatch_Call if we still have a call, before expanding
-- extra actuals since this will be done on the re-analysis of the
-- dispatching call. Note that we do not try to shorten the actual
and then Present (Controlling_Argument (N))
and then not Java_VM
then
- Expand_Dispatch_Call (N);
+ Expand_Dispatching_Call (N);
-- The following return is worrisome. Is it really OK to
-- skip all remaining processing in this procedure ???
end loop;
end if;
- if Ekind (Subp) = E_Procedure
- or else (Ekind (Subp) = E_Subprogram_Type
- and then Etype (Subp) = Standard_Void_Type)
- or else Is_Entry (Subp)
- then
- Expand_Actuals (N, Subp);
- end if;
+ -- At this point we have all the actuals, so this is the point at
+ -- which the various expansion activities for actuals is carried out.
+
+ Expand_Actuals (N, Subp);
-- If the subprogram is a renaming, or if it is inherited, replace it
-- in the call with the name of the actual subprogram being called.
end loop;
end if;
+ -- The below setting of Entity is suspect, see F109-018 discussion???
+
Set_Entity (Name (N), Parent_Subp);
if Is_Abstract (Parent_Subp)
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
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,
Designated_Type (Base_Type (Etype (Ptr)));
begin
- Obj := Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (T, Ptr),
- Selector_Name => New_Occurrence_Of (First_Entity (T), Loc));
-
- Nam := Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (T, Ptr),
- Selector_Name => New_Occurrence_Of (
- Next_Entity (First_Entity (T)), Loc));
+ Obj :=
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (T, Ptr),
+ Selector_Name =>
+ New_Occurrence_Of (First_Entity (T), Loc));
+
+ Nam :=
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (T, Ptr),
+ Selector_Name =>
+ New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc));
Nam := Make_Explicit_Dereference (Loc, Nam);
-- appropriate expansion to the corresponding tree node and we
-- are all done (since after that the call is gone!)
+ -- In the case where the intrinsic is to be processed by the back end,
+ -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
+ -- since the idea in this case is to pass the call unchanged.
+
if Is_Intrinsic_Subprogram (Subp) then
Expand_Intrinsic_Call (N, Subp);
return;
--------------------------
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
-- 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
-- call, or a protected function call. Protected procedure calls are
-- rewritten as entry calls and handled accordingly.
+ -- In Ada 2005, this may be an indirect call to an access parameter
+ -- that is an access_to_subprogram. In that case the anonymous type
+ -- has a scope that is a protected operation, but the call is a
+ -- regular one.
+
Scop := Scope (Subp);
if Nkind (N) /= N_Entry_Call_Statement
and then Is_Protected_Type (Scop)
+ and then Ekind (Subp) /= E_Subprogram_Type
then
-- If the call is an internal one, it is rewritten as a call to
-- to the corresponding unprotected subprogram.
end if;
end;
end if;
+
+ -- Special processing for Ada 2005 AI-329, which requires a call to
+ -- Raise_Exception to raise Constraint_Error if the Exception_Id is
+ -- null. Note that we never need to do this in GNAT mode, or if the
+ -- parameter to Raise_Exception is a use of Identity, since in these
+ -- cases we know that the parameter is never null.
+
+ if Ada_Version >= Ada_05
+ and then not GNAT_Mode
+ and then Is_RTE (Subp, RE_Raise_Exception)
+ and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
+ or else Attribute_Name (First_Actual (N)) /= Name_Identity)
+ then
+ declare
+ RCE : constant Node_Id :=
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Null_Exception_Id);
+ begin
+ Insert_After (N, RCE);
+ Analyze (RCE);
+ end;
+ end if;
end Expand_Call;
--------------------------
Blk : Node_Id;
Bod : Node_Id;
Decl : Node_Id;
+ Decls : constant List_Id := New_List;
Exit_Lab : Entity_Id := Empty;
F : Entity_Id;
A : Node_Id;
Num_Ret : Int := 0;
Ret_Type : Entity_Id;
Targ : Node_Id;
+ Targ1 : Node_Id;
Temp : Entity_Id;
Temp_Typ : Entity_Id;
+ Is_Unc : constant Boolean :=
+ Is_Array_Type (Etype (Subp))
+ and then not Is_Constrained (Etype (Subp));
+ -- If the type returned by the function is unconstrained and the
+ -- call can be inlined, special processing is required.
+
+ procedure Find_Result;
+ -- For a function that returns an unconstrained type, retrieve the
+ -- name of the single variable that is the expression of a return
+ -- statement in the body of the function. Build_Body_To_Inline has
+ -- verified that this variable is unique, even in the presence of
+ -- multiple return statements.
+
procedure Make_Exit_Label;
- -- Build declaration for exit label to be used in Return statements.
+ -- Build declaration for exit label to be used in Return statements
function Process_Formals (N : Node_Id) return Traverse_Result;
-- Replace occurrence of a formal with the corresponding actual, or
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod
+ -----------------
+ -- Find_Result --
+ -----------------
+
+ procedure Find_Result is
+ Decl : Node_Id;
+ Id : Node_Id;
+
+ function Get_Return (N : Node_Id) return Traverse_Result;
+ -- Recursive function to locate return statements in body.
+
+ function Get_Return (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Return_Statement then
+ Id := Expression (N);
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Get_Return;
+
+ procedure Find_It is new Traverse_Proc (Get_Return);
+
+ -- Start of processing for Find_Result
+
+ begin
+ Find_It (Handled_Statement_Sequence (Orig_Bod));
+
+ -- At this point the body is unanalyzed. Traverse the list of
+ -- declarations to locate the defining_identifier for it.
+
+ Decl := First (Declarations (Blk));
+
+ while Present (Decl) loop
+ if Chars (Defining_Identifier (Decl)) = Chars (Id) then
+ Targ1 := Defining_Identifier (Decl);
+ exit;
+
+ else
+ Next (Decl);
+ end if;
+ end loop;
+ end Find_Result;
+
---------------------
-- Make_Exit_Label --
---------------------
procedure Make_Exit_Label is
begin
- -- Create exit label for subprogram, if one doesn't exist yet.
+ -- Create exit label for subprogram if one does not exist yet
if No (Exit_Lab) then
Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L'));
elsif Nkind (N) = N_Identifier
and then Nkind (Parent (Entity (N))) = N_Object_Declaration
then
-
- -- The block assigns the result of the call to the temporary.
+ -- The block assigns the result of the call to the temporary
Insert_After (Parent (Entity (N)), Blk);
elsif Nkind (Parent (N)) = N_Assignment_Statement
- and then Is_Entity_Name (Name (Parent (N)))
+ and then
+ (Is_Entity_Name (Name (Parent (N)))
+ or else
+ (Nkind (Name (Parent (N))) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Name (Parent (N))))))
then
-
-- Replace assignment with the block
declare
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);
elsif Nkind (Parent (N)) = N_Object_Declaration then
Set_Expression (Parent (N), Empty);
Insert_After (Parent (N), Blk);
+
+ elsif Is_Unc then
+ Insert_Before (Parent (N), Blk);
end if;
end Rewrite_Function_Call;
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)))
-- Start of processing for Expand_Inlined_Call
begin
- -- 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 a
- -- problem with order of elaboration when address clauses
- -- are inlined (address expr elaborated at wrong point).
+ -- 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 expression elaborated at
+ -- wrong point).
if Subp = RTE (RE_To_Address) then
Rewrite (N,
return;
end if;
- if Nkind (Orig_Bod) = N_Defining_Identifier then
+ -- Check for an illegal attempt to inline a recursive procedure. If the
+ -- subprogram has parameters this is detected when trying to supply a
+ -- binding for parameters that already have one. For parameterless
+ -- subprograms this must be done explicitly.
+ if In_Open_Scopes (Subp) then
+ Error_Msg_N ("call to recursive subprogram cannot be inlined?", N);
+ Set_Is_Inlined (Subp, False);
+ return;
+ end if;
+
+ if Nkind (Orig_Bod) = N_Defining_Identifier
+ or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
+ then
-- Subprogram is a renaming_as_body. Calls appearing after the
-- renaming can be replaced with calls to the renamed entity
- -- directly, because the subprograms are subtype conformant.
+ -- directly, because the subprograms are subtype conformant. If
+ -- the renamed subprogram is an inherited operation, we must redo
+ -- the expansion because implicit conversions may be needed.
Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
+
+ if Present (Alias (Orig_Bod)) then
+ Expand_Call (N);
+ end if;
+
return;
end if;
Set_Declarations (Blk, New_List);
end if;
- -- If this is a derived function, establish the proper return type.
+ -- For the unconstrained case, capture the name of the local
+ -- variable that holds the result.
+
+ if Is_Unc then
+ Find_Result;
+ end if;
+
+ -- If this is a derived function, establish the proper return type
if Present (Orig_Subp)
and then Orig_Subp /= Subp
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;
-- If the argument may be a controlling argument in a call within
- -- the inlined body, we must preserve its classwide nature to
- -- insure that dynamic dispatching take place subsequently.
- -- If the formal has a constraint it must be preserved to retain
- -- the semantics of the body.
+ -- the inlined body, we must preserve its classwide nature to insure
+ -- that dynamic dispatching take place subsequently. If the formal
+ -- has a constraint it must be preserved to retain the semantics of
+ -- the body.
if Is_Class_Wide_Type (Etype (F))
or else (Is_Access_Type (Etype (F))
Name => New_A);
end if;
- Prepend (Decl, Declarations (Blk));
+ Append (Decl, Decls);
Set_Renamed_Object (F, Temp);
end if;
-- declaration, create a temporary as a target. The declaration for
-- the temporary may be subsequently optimized away if the body is a
-- single expression, or if the left-hand side of the assignment is
- -- simple enough.
+ -- simple enough, i.e. an entity or an explicit dereference of one.
if Ekind (Subp) = E_Function then
if Nkind (Parent (N)) = N_Assignment_Statement
then
Targ := Name (Parent (N));
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Name (Parent (N))))
+ then
+ Targ := Name (Parent (N));
+
else
- -- Replace call with temporary, and create its declaration.
+ -- Replace call with temporary and create its declaration
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+ Set_Is_Internal (Temp);
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Ret_Type, Loc));
+ -- For the unconstrained case. the generated temporary has the
+ -- same constrained declaration as the result variable.
+ -- It may eventually be possible to remove that temporary and
+ -- use the result variable directly.
+
+ if Is_Unc then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Copy_Tree (Object_Definition (Parent (Targ1))));
+
+ Replace_Formals (Decl);
+
+ else
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Ret_Type, Loc));
+
+ Set_Etype (Temp, Ret_Type);
+ end if;
Set_No_Initialization (Decl);
- Insert_Action (N, Decl);
+ Append (Decl, Decls);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Targ := Temp;
end if;
end if;
- -- Traverse the tree and replace formals with actuals or their thunks.
+ Insert_Actions (N, Decls);
+
+ -- Traverse the tree and replace formals with actuals or their thunks.
-- Attach block to tree before analysis and rewriting.
Replace_Formals (Blk);
end if;
-- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
- -- conflicting private views that Gigi would ignore. If this is a
+ -- conflicting private views that Gigi would ignore. If this is
-- predefined unit, analyze with checks off, as is done in the non-
-- inlined run-time units.
Rewrite_Procedure_Call (N, Blk);
else
Rewrite_Function_Call (N, Blk);
+
+ -- For the unconstrained case, the replacement of the call has been
+ -- made prior to the complete analysis of the generated declarations.
+ -- Propagate the proper type now.
+
+ if Is_Unc then
+ if Nkind (N) = N_Identifier then
+ Set_Etype (N, Etype (Entity (N)));
+ else
+ Set_Etype (N, Etype (Targ1));
+ end if;
+ end if;
end if;
Restore_Env;
- -- Cleanup mapping between formals and actuals, for other expansions.
+ -- 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);
-- by reference, we don't want to create a temp to force stack checking.
-- Shouldn't this function be moved to exp_util???
+ function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean;
+ -- If the call is the right side of an assignment or the expression in
+ -- an object declaration, we don't need to create a temp as the left
+ -- side will already trigger stack checking if necessary.
+ --
+ -- If the call is a component in an extension aggregate, it will be
+ -- expanded into assignments as well, so no temporary is needed. This
+ -- also solves the problem of functions returning types with unknown
+ -- discriminants, where it is not possible to declare an object of the
+ -- type altogether.
+
---------------------------
-- Returned_By_Reference --
---------------------------
function Returned_By_Reference return Boolean is
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
if Is_Return_By_Reference_Type (Typ) then
elsif Requires_Transient_Scope (Typ) then
- -- Verify that the return type of the enclosing function has
- -- the same constrained status as that of the expression.
+ -- 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;
end if;
end Returned_By_Reference;
+ ---------------------------
+ -- Rhs_Of_Assign_Or_Decl --
+ ---------------------------
+
+ function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean is
+ begin
+ if (Nkind (Parent (N)) = N_Assignment_Statement
+ and then Expression (Parent (N)) = N)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
+ and then Expression (Parent (Parent (N))) = Parent (N))
+ or else
+ (Nkind (Parent (N)) = N_Object_Declaration
+ and then Expression (Parent (N)) = N)
+ or else
+ (Nkind (Parent (N)) = N_Component_Association
+ and then Expression (Parent (N)) = N
+ and then Nkind (Parent (Parent (N))) = N_Aggregate
+ and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N))))
+ or else
+ (Nkind (Parent (N)) = N_Extension_Aggregate
+ and then Is_Private_Type (Etype (Typ)))
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Rhs_Of_Assign_Or_Decl;
+
-- Start of processing for Expand_N_Function_Call
begin
-- A special check. If stack checking is enabled, and the return type
- -- might generate a large temporary, and the call is not the right
- -- side of an assignment, then generate an explicit temporary. We do
- -- this because otherwise gigi may generate a large temporary on the
- -- fly and this can cause trouble with stack checking.
+ -- might generate a large temporary, and the call is not the right side
+ -- of an assignment, then generate an explicit temporary. We do this
+ -- because otherwise gigi may generate a large temporary on the fly and
+ -- this can cause trouble with stack checking.
+
+ -- This is unecessary if the call is the expression in an object
+ -- declaration, or if it appears outside of any library unit. This can
+ -- only happen if it appears as an actual in a library-level instance,
+ -- in which case a temporary will be generated for it once the instance
+ -- itself is installed.
if May_Generate_Large_Temp (Typ)
- and then Nkind (Parent (N)) /= N_Assignment_Statement
- and then
- (Nkind (Parent (N)) /= N_Qualified_Expression
- or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement)
- and then
- (Nkind (Parent (N)) /= N_Object_Declaration
- or else Expression (Parent (N)) /= N)
+ and then not Rhs_Of_Assign_Or_Decl (N)
and then not Returned_By_Reference
+ and then Current_Scope /= Standard_Standard
then
if Stack_Checking_Enabled then
- -- Note: it might be thought that it would be OK to use a call
- -- to Force_Evaluation here, but that's not good enough, because
- -- that can results in a 'Reference construct that may still
- -- need a temporary.
+ -- Note: it might be thought that it would be OK to use a call to
+ -- Force_Evaluation here, but that's not good enough, because
+ -- that can results in a 'Reference construct that may still need
+ -- a temporary.
declare
Loc : constant Source_Ptr := Sloc (N);
-- object is not classwide.
Proc := Entity (Name (Parent (N)));
- F := First_Formal (Proc);
- A := First_Actual (Parent (N));
+ F := First_Formal (Proc);
+ A := First_Actual (Parent (N));
while A /= N loop
Next_Formal (F);
Next_Actual (A);
-- Expand_N_Subprogram_Body --
------------------------------
- -- Add poll call if ATC polling is enabled
+ -- Add poll call if ATC polling is enabled, unless the body will be
+ -- inlined by the back-end.
- -- Add return statement if last statement in body is not a return
- -- statement (this makes things easier on Gigi which does not want
- -- to have to handle a missing return).
+ -- Add return statement if last statement in body is not a return statement
+ -- (this makes things easier on Gigi which does not want to have to handle
+ -- a missing return).
-- Add call to Activate_Tasks if body is a task activator
L := Statements (Handled_Statement_Sequence (N));
end if;
- -- Need poll on entry to subprogram if polling enabled. We only
- -- do this for non-empty subprograms, since it does not seem
- -- necessary to poll for a dummy null subprogram.
-
- if Is_Non_Empty_List (L) then
- Generate_Poll_Call (First (L));
- end if;
-
-- Find entity for subprogram
Body_Id := Defining_Entity (N);
Spec_Id := Body_Id;
end if;
+ -- Need poll on entry to subprogram if polling enabled. We only
+ -- do this for non-empty subprograms, since it does not seem
+ -- necessary to poll for a dummy null subprogram. Do not add polling
+ -- point if calls to this subprogram will be inlined by the back-end,
+ -- to avoid repeated polling points in nested inlinings.
+
+ if Is_Non_Empty_List (L) then
+ if Is_Inlined (Spec_Id)
+ and then Front_End_Inlining
+ and then Optimization_Level > 1
+ then
+ null;
+ else
+ Generate_Poll_Call (First (L));
+ end if;
+ end if;
+
-- If this is a Pure function which has any parameters whose root
-- type is System.Address, reset the Pure indication, since it will
-- likely cause incorrect code to be generated as the parameter 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);
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
-- 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
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)))
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);
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);
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);
end loop;
end if;
- -- For a function, we must deal with the case where there is at
- -- least one missing return. What we do is to wrap the entire body
- -- of the function in a block:
+ -- For a function, we must deal with the case where there is at least
+ -- one missing return. What we do is to wrap the entire body of the
+ -- function in a block:
-- begin
-- ...
begin
Formal := First_Formal (Spec_Id);
-
while Present (Formal) loop
Floc := Sloc (Formal);
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);
-- protected subprogram an associated formals. For a normal protected
-- operation, this is done when expanding the protected type declaration.
+ -- If the declaration is for a null procedure, emit null body
+
procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Subp : constant Entity_Id := Defining_Entity (N);
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)))
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
Set_Protected_Body_Subprogram (Subp, Prot_Id);
Pop_Scope;
end if;
+
+ elsif Nkind (Specification (N)) = N_Procedure_Specification
+ and then Null_Present (Specification (N))
+ then
+ declare
+ Bod : constant Node_Id :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ New_Copy_Tree (Specification (N)),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Make_Null_Statement (Loc))));
+ begin
+ Set_Body_To_Inline (N, Bod);
+ Insert_After (N, Bod);
+ Analyze (Bod);
+
+ -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
+ -- evidently because Set_Has_Completion is called earlier for null
+ -- procedures in Analyze_Subprogram_Declaration, so we force its
+ -- setting here. If the setting of Has_Completion is not set
+ -- earlier, then it can result in missing body errors if other
+ -- errors were already reported (since expansion is turned off).
+
+ -- Should creation of the empty body be moved to the analyzer???
+
+ Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N)));
+ end;
end if;
end Expand_N_Subprogram_Declaration;
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
if Is_Subprogram (Proc)
and then Proc /= Corr
then
- -- Protected function or procedure.
+ -- Protected function or procedure
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;
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);
-----------------------
procedure Freeze_Subprogram (N : Node_Id) is
- E : constant Entity_Id := Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ E : constant Entity_Id := Entity (N);
+
+ 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.
+
+ procedure Register_Interface_DT_Entry
+ (Prim : Entity_Id;
+ Ancestor_Iface_Prim : Entity_Id := Empty);
+ -- (Ada 2005): Register an interface primitive in a secondary dispatch
+ -- table. If Prim overrides an ancestor primitive of its associated
+ -- tagged-type then Ancestor_Iface_Prim indicates the entity of that
+ -- immediate ancestor associated with the interface.
+
+ procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
+ -- (Ada 2005): Register a predefined primitive in all the secondary
+ -- dispatch tables of its primitive type.
+
+ -------------------------------------------
+ -- Check_Overriding_Inherited_Interfaces --
+ -------------------------------------------
+
+ procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is
+ Typ : Entity_Id;
+ Elmt : Elmt_Id;
+ Prim_Op : Entity_Id;
+ Overriden_Op : Entity_Id := Empty;
+
+ begin
+ if Ada_Version < Ada_05
+ or else not Is_Overriding_Operation (E)
+ or else Is_Predefined_Dispatching_Operation (E)
+ or else Present (Alias (E))
+ then
+ return;
+ end if;
+
+ -- Get the entity associated with this primitive operation
+
+ Typ := Scope (DTC_Entity (E));
+ loop
+ exit when Etype (Typ) = Typ
+ or else (Present (Full_View (Etype (Typ)))
+ and then Full_View (Etype (Typ)) = Typ);
+
+ -- Climb to the immediate ancestor handling private types
+
+ if Present (Full_View (Etype (Typ))) then
+ Typ := Full_View (Etype (Typ));
+ else
+ Typ := Etype (Typ);
+ end if;
+
+ if Present (Abstract_Interfaces (Typ)) then
+
+ -- Look for the overriden subprogram in the primary dispatch
+ -- table of the ancestor.
+
+ Overriden_Op := Empty;
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim_Op := Node (Elmt);
+
+ 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 No (Abstract_Interface_Alias (Prim_Op))
+ then
+ if Overriden_Op = Empty then
+ 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 Overriden_Op /= Empty then
+
+ -- Find the entries associated with interfaces that are
+ -- alias of this primitive operation in the ancestor.
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim_Op := Node (Elmt);
+
+ if Present (Abstract_Interface_Alias (Prim_Op))
+ and then Alias (Prim_Op) = Overriden_Op
+ then
+ Register_Interface_DT_Entry (E, Prim_Op);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end if;
+ end loop;
+ end Check_Overriding_Inherited_Interfaces;
+
+ ---------------------------------
+ -- Register_Interface_DT_Entry --
+ ---------------------------------
+
+ procedure Register_Interface_DT_Entry
+ (Prim : Entity_Id;
+ Ancestor_Iface_Prim : Entity_Id := Empty)
+ is
+ E : Entity_Id;
+ Prim_Typ : Entity_Id;
+ Prim_Op : Entity_Id;
+ Iface_Typ : Entity_Id;
+ Iface_DT_Ptr : Entity_Id;
+ Iface_Tag : Entity_Id;
+ New_Thunk : Node_Id;
+ Thunk_Id : Entity_Id;
+
+ begin
+ -- Nothing to do if the run-time does not give support to abstract
+ -- interfaces.
+
+ if not (RTE_Available (RE_Interface_Tag)) then
+ return;
+ end if;
+
+ if No (Ancestor_Iface_Prim) then
+ Prim_Typ := Scope (DTC_Entity (Alias (Prim)));
+
+ -- Look for the abstract interface subprogram
+
+ E := Abstract_Interface_Alias (Prim);
+ while Present (E)
+ and then Is_Abstract (E)
+ and then not Is_Interface (Scope (DTC_Entity (E)))
+ loop
+ E := Alias (E);
+ end loop;
+
+ Iface_Typ := Scope (DTC_Entity (E));
+
+ -- Generate the code of the thunk only when this primitive
+ -- operation is associated with a secondary dispatch table.
+
+ if Is_Interface (Iface_Typ) then
+ Iface_Tag := Find_Interface_Tag
+ (T => Prim_Typ,
+ Iface => Iface_Typ);
+
+ if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+ Thunk_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ New_Thunk :=
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Alias (Prim),
+ Thunk_Id => Thunk_Id);
+
+ Insert_After (N, New_Thunk);
+
+ Iface_DT_Ptr :=
+ Find_Interface_ADT
+ (T => Prim_Typ,
+ Iface => Iface_Typ);
+
+ Insert_After (New_Thunk,
+ Fill_Secondary_DT_Entry (Sloc (Prim),
+ Prim => Prim,
+ Iface_DT_Ptr => Iface_DT_Ptr,
+ Thunk_Id => Thunk_Id));
+ end if;
+ end if;
+
+ else
+ Iface_Typ :=
+ Scope (DTC_Entity (Abstract_Interface_Alias
+ (Ancestor_Iface_Prim)));
+
+ Iface_Tag :=
+ Find_Interface_Tag
+ (T => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))),
+ Iface => Iface_Typ);
+
+ -- Generate the thunk only if the associated tag is an interface
+ -- tag. The case in which the associated tag is the primary tag
+ -- occurs when a tagged type is a direct derivation of an
+ -- interface. For example:
+
+ -- type I is interface;
+ -- ...
+ -- type T is new I with ...
+
+ if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+ Thunk_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ if Present (Alias (Prim)) then
+ Prim_Op := Alias (Prim);
+ else
+ Prim_Op := Prim;
+ end if;
+
+ New_Thunk :=
+ Expand_Interface_Thunk
+ (N => Ancestor_Iface_Prim,
+ Thunk_Alias => Prim_Op,
+ Thunk_Id => Thunk_Id);
+
+ Insert_After (N, New_Thunk);
+
+ Iface_DT_Ptr :=
+ Find_Interface_ADT
+ (T => Scope (DTC_Entity (Prim_Op)),
+ Iface => Iface_Typ);
+
+ Insert_After (New_Thunk,
+ Fill_Secondary_DT_Entry (Sloc (Prim),
+ Prim => Ancestor_Iface_Prim,
+ Iface_DT_Ptr => Iface_DT_Ptr,
+ Thunk_Id => Thunk_Id));
+ end if;
+ end if;
+ end Register_Interface_DT_Entry;
+
+ ----------------------------------
+ -- Register_Predefined_DT_Entry --
+ ----------------------------------
+
+ procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
+ Iface_DT_Ptr : Elmt_Id;
+ Iface_Tag : Entity_Id;
+ Iface_Typ : Elmt_Id;
+ New_Thunk : Entity_Id;
+ Prim_Typ : Entity_Id;
+ Thunk_Id : Entity_Id;
+
+ begin
+ Prim_Typ := Scope (DTC_Entity (Prim));
+
+ if No (Access_Disp_Table (Prim_Typ))
+ or else No (Abstract_Interfaces (Prim_Typ))
+ or else not RTE_Available (RE_Interface_Tag)
+ then
+ return;
+ end if;
+
+ -- Skip the first acces-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.
+
+ Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Prim_Typ)));
+ Iface_Typ := First_Elmt (Abstract_Interfaces (Prim_Typ));
+ while Present (Iface_DT_Ptr) and then Present (Iface_Typ) loop
+ Iface_Tag := Find_Interface_Tag (Prim_Typ, Node (Iface_Typ));
+ pragma Assert (Present (Iface_Tag));
+
+ if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+ Thunk_Id := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T'));
+
+ New_Thunk :=
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Prim,
+ Thunk_Id => Thunk_Id);
+
+ Insert_After (N, New_Thunk);
+ Insert_After (New_Thunk,
+ Make_DT_Access_Action (Node (Iface_Typ),
+ Action => Set_Predefined_Prim_Op_Address,
+ Args => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Node (Iface_DT_Ptr), Loc)),
+
+ Make_Integer_Literal (Loc, DT_Position (Prim)),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Address))));
+ end if;
+
+ Next_Elmt (Iface_DT_Ptr);
+ Next_Elmt (Iface_Typ);
+ end loop;
+ end Register_Predefined_DT_Entry;
+
+ -- Start of processing for Freeze_Subprogram
begin
-- When a primitive is frozen, enter its name in the corresponding
if Is_Dispatching_Operation (E)
and then not Is_Abstract (E)
and then Present (DTC_Entity (E))
- and then not Is_CPP_Class (Scope (DTC_Entity (E)))
and then not Java_VM
+ and then not Is_CPP_Class (Scope (DTC_Entity (E)))
then
Check_Overriding_Operation (E);
- Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+
+ -- Ada 95 case: Register the subprogram in the primary dispatch table
+
+ if Ada_Version < Ada_05 then
+
+ -- Do not register the subprogram in the dispatch table if we
+ -- are compiling with the No_Dispatching_Calls restriction.
+
+ if not Restriction_Active (No_Dispatching_Calls) then
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
+ end if;
+
+ -- Ada 2005 case: Register the subprogram in the secondary dispatch
+ -- tables associated with abstract interfaces.
+
+ else
+ declare
+ Typ : constant Entity_Id := Scope (DTC_Entity (E));
+
+ begin
+ -- There is no dispatch table associated with abstract
+ -- interface types. Each type implementing interfaces will
+ -- fill the associated secondary DT entries.
+
+ if not Is_Interface (Typ)
+ or else Present (Alias (E))
+ then
+ -- Ada 2005 (AI-251): Check if this entry corresponds with
+ -- a subprogram that covers an abstract interface type.
+
+ if Present (Abstract_Interface_Alias (E)) then
+ Register_Interface_DT_Entry (E);
+
+ -- Common case: Primitive subprogram
+
+ else
+ -- Generate thunks for all the predefined operations
+
+ if not Restriction_Active (No_Dispatching_Calls) then
+ if Is_Predefined_Dispatching_Operation (E) then
+ Register_Predefined_DT_Entry (E);
+ end if;
+
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
+ end if;
+
+ Check_Overriding_Inherited_Interfaces (E);
+ end if;
+ end if;
+ end;
+ end if;
end if;
-- 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);
OSDN Git Service
