-- --
-- 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 Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
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 Restrictions (No_Implicit_Conditionals) then
+ if Restriction_Active (No_Implicit_Conditionals) then
return;
end if;
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
---------------------------
procedure Add_Call_By_Copy_Code is
- Expr : Node_Id;
- Init : Node_Id;
- Temp : Entity_Id;
- Var : Entity_Id;
- V_Typ : Entity_Id;
- Crep : Boolean;
+ Expr : Node_Id;
+ Init : Node_Id;
+ Temp : Entity_Id;
+ 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));
Var := Make_Var (Expression (Actual));
Crep := not Same_Representation
- (Etype (Formal), Etype (Expression (Actual)));
+ (F_Typ, Etype (Expression (Actual)));
else
V_Typ := Etype (Actual);
-- parameter where the formal is an unconstrained array (in the
-- latter case, we have to pass in an object with bounds).
+ -- If this is an out parameter, the initial copy is wasteful, so as
+ -- an optimization for the one-dimensional case we extract the
+ -- bounds of the actual and build an uninitialized temporary of the
+ -- right size.
+
if Ekind (Formal) = E_In_Out_Parameter
- or else (Is_Array_Type (Etype (Formal))
- and then
- not Is_Constrained (Etype (Formal)))
+ or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
then
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
- Init := OK_Convert_To
- (Etype (Formal), New_Occurrence_Of (Var, Loc));
+ Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
- Init := Convert_To
- (Etype (Formal), New_Occurrence_Of (Var, Loc));
+ Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
+
+ elsif Ekind (Formal) = E_Out_Parameter
+ and then Is_Array_Type (F_Typ)
+ and then Number_Dimensions (F_Typ) = 1
+ and then not Has_Non_Null_Base_Init_Proc (F_Typ)
+ then
+ -- Actual is a one-dimensional array or slice, and the type
+ -- requires no initialization. Create a temporary of the
+ -- right size, but do not copy actual into it (optimization).
+
+ Init := Empty;
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (F_Typ, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Var, Loc),
+ Attribute_name => Name_First),
+ High_Bound =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Var, Loc),
+ Attribute_Name => Name_Last)))));
+
else
Init := New_Occurrence_Of (Var, Loc);
end if;
elsif Ekind (Formal) = E_Out_Parameter
and then Nkind (Actual) = N_Type_Conversion
- and then (Is_Bit_Packed_Array (Etype (Formal))
+ and then (Is_Bit_Packed_Array (F_Typ)
or else
Is_Bit_Packed_Array (Etype (Expression (Actual))))
then
if Conversion_OK (Actual) then
- Init :=
- OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
+ Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
- Init :=
- Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
+ Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
+
+ elsif Ekind (Formal) = E_In_Parameter then
+ Init := New_Occurrence_Of (Var, Loc);
+
else
Init := Empty;
end if;
N_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Etype (Formal), Loc),
- Expression => Init);
+ Object_Definition => Indic,
+ 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
-- if we can tell that the first parameter cannot possibly be null.
-- This helps optimization and also generation of warnings.
- if not Restrictions (No_Exception_Handlers)
+ if not Restriction_Active (No_Exception_Handlers)
and then Is_RTE (Subp, RE_Raise_Exception)
then
declare
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
New_Occurrence_Of (Standard_True, Loc),
Extra_Constrained (Formal));
+ -- Do not produce extra actuals for Unchecked_Union parameters.
+ -- Jump directly to the end of the loop.
+
+ elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
+ goto Skip_Extra_Actual_Generation;
+
else
-- If the actual is a type conversion, then the constrained
-- 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;
-- When passing an access parameter as the actual to another
-- access parameter we need to pass along the actual's own
- -- associated access level parameter. This is done is we are
+ -- associated access level parameter. This is done if we are
-- in the scope of the formal access parameter (if this is an
-- inlined body the extra formal is irrelevant).
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;
- else
- 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 Is_Entity_Name (Prev)
+ and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
+ then
+ 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
Get_Remotely_Callable
(Duplicate_Subexpr_Move_Checks (Actual))),
Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- New_Occurrence_Of (RTE
- (RE_Raise_Program_Error_For_E_4_18), Loc)))));
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Illegal_RACW_E_4_18))));
end if;
+ -- This label is required when skipping extra actual generation for
+ -- Unchecked_Union parameters.
+
+ <<Skip_Extra_Actual_Generation>>
+
Next_Actual (Actual);
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,
Subp := Parent_Subp;
end if;
+ -- Check for violation of No_Abort_Statements
+
if Is_RTE (Subp, RE_Abort_Task) then
Check_Restriction (No_Abort_Statements, N);
+
+ -- Check for violation of No_Dynamic_Attachment
+
+ elsif RTU_Loaded (Ada_Interrupts)
+ and then (Is_RTE (Subp, RE_Is_Reserved) or else
+ Is_RTE (Subp, RE_Is_Attached) or else
+ Is_RTE (Subp, RE_Current_Handler) or else
+ Is_RTE (Subp, RE_Attach_Handler) or else
+ Is_RTE (Subp, RE_Exchange_Handler) or else
+ Is_RTE (Subp, RE_Detach_Handler) or else
+ Is_RTE (Subp, RE_Reference))
+ then
+ Check_Restriction (No_Dynamic_Attachment, N);
end if;
+ -- Deal with case where call is an explicit dereference
+
if Nkind (Name (N)) = N_Explicit_Dereference then
-- Handle case of access to protected subprogram type
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;
then
if Is_Inlined (Subp) then
- declare
+ Inlined_Subprogram : declare
Bod : Node_Id;
Must_Inline : Boolean := False;
Spec : constant Node_Id := Unit_Declaration_Node (Subp);
Scop : constant Entity_Id := Scope (Subp);
+ function In_Unfrozen_Instance return Boolean;
+ -- If the subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems in gigi.
+
+ --------------------------
+ -- In_Unfrozen_Instance --
+ --------------------------
+
+ function In_Unfrozen_Instance return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Scop;
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then Present (Freeze_Node (S))
+ and then not Analyzed (Freeze_Node (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Unfrozen_Instance;
+
+ -- 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
then
Must_Inline := False;
- -- If the subprogram comes from an instance in the same
- -- unit, and the instance is not yet frozen, inlining might
- -- trigger order-of-elaboration problems in gigi.
-
- elsif Is_Generic_Instance (Scop)
- and then Present (Freeze_Node (Scop))
- and then not Analyzed (Freeze_Node (Scop))
- then
+ elsif In_Unfrozen_Instance then
Must_Inline := False;
else
-- temporaries are generated when compiling the body by
-- itself. Otherwise link errors can occur.
+ -- If the function being called is itself in the main unit,
+ -- we cannot inline, because there is a risk of double
+ -- elaboration and/or circularity: the inlining can make
+ -- visible a private entity in the body of the main unit,
+ -- that gigi will see before its sees its proper definition.
+
elsif not (In_Extended_Main_Code_Unit (N))
and then In_Package_Body
then
- Must_Inline := True;
+ Must_Inline := not In_Extended_Main_Source_Unit (Subp);
end if;
end if;
N, Subp);
end if;
end if;
- end;
+ end Inlined_Subprogram;
end if;
end if;
-- 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
-- If procedure body has no local variables, inline body without
-- creating block, otherwise rewrite call with block.
+ 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
- Rewrite (Parent (N), Blk);
+ 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).
+
+ -- 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);
+ end;
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;
procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
-
begin
if Is_Empty_List (Declarations (Blk)) then
Insert_List_After (N, Statements (HSS));
end if;
end Rewrite_Procedure_Call;
+ -------------------------
+ -- Formal_Is_Used_Once --
+ ------------------------
+
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
+ Use_Counter : Int := 0;
+
+ function Count_Uses (N : Node_Id) return Traverse_Result;
+ -- Traverse the tree and count the uses of the formal parameter.
+ -- In this case, for optimization purposes, we do not need to
+ -- continue the traversal once more than one use is encountered.
+
+ ----------------
+ -- Count_Uses --
+ ----------------
+
+ function Count_Uses (N : Node_Id) return Traverse_Result is
+ begin
+ -- The original node is an identifier
+
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+
+ -- 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)))
+
+ -- The entity of the copied node is the formal parameter
+
+ and then Entity (Entity (N)) = Formal
+ then
+ Use_Counter := Use_Counter + 1;
+
+ if Use_Counter > 1 then
+
+ -- Denote more than one use and abandon the traversal
+
+ Use_Counter := 2;
+ return Abandon;
+
+ end if;
+ end if;
+
+ return OK;
+ end Count_Uses;
+
+ procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
+
+ -- Start of processing for Formal_Is_Used_Once
+
+ begin
+ Count_Formal_Uses (Orig_Bod);
+ return Use_Counter = 1;
+ end Formal_Is_Used_Once;
+
-- 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 Present (Orig_Subp)
+ 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
then
Ret_Type := Etype (Orig_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))
(not Is_Scalar_Type (Etype (A))
or else Ekind (Entity (A)) = E_Enumeration_Literal))
+ -- When the actual is an identifier and the corresponding formal
+ -- is used only once in the original body, the formal can be
+ -- substituted directly with the actual parameter.
+
+ or else (Nkind (A) = N_Identifier
+ and then Formal_Is_Used_Once (F))
+
or else Nkind (A) = N_Real_Literal
or else Nkind (A) = N_Integer_Literal
or else Nkind (A) = N_Character_Literal
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);
----------------------------
procedure Expand_N_Function_Call (N : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (N);
function Returned_By_Reference return Boolean;
-- If the return type is returned through the secondary stack. that is
-- 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
- -- 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
- -- results in a 'Reference construct that may still need a temporary.
+ if Stack_Checking_Enabled then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Temp_Obj : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('F'));
- Temp_Typ : Entity_Id := Typ;
- Decl : Node_Id;
- A : Node_Id;
- F : Entity_Id;
- Proc : Entity_Id;
+ -- 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.
- begin
- if Is_Tagged_Type (Typ)
- and then Present (Controlling_Argument (N))
- then
- if Nkind (Parent (N)) /= N_Procedure_Call_Statement
- and then Nkind (Parent (N)) /= N_Function_Call
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp_Obj : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('F'));
+ Temp_Typ : Entity_Id := Typ;
+ Decl : Node_Id;
+ A : Node_Id;
+ F : Entity_Id;
+ Proc : Entity_Id;
+
+ begin
+ if Is_Tagged_Type (Typ)
+ and then Present (Controlling_Argument (N))
then
- -- If this is a tag-indeterminate call, the object must
- -- be classwide.
+ if Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ and then Nkind (Parent (N)) /= N_Function_Call
+ then
+ -- If this is a tag-indeterminate call, the object must
+ -- be classwide.
- if Is_Tag_Indeterminate (N) then
- Temp_Typ := Class_Wide_Type (Typ);
- end if;
+ if Is_Tag_Indeterminate (N) then
+ Temp_Typ := Class_Wide_Type (Typ);
+ end if;
- else
- -- If this is a dispatching call that is itself the
- -- controlling argument of an enclosing call, the nominal
- -- subtype of the object that replaces it must be classwide,
- -- so that dispatching will take place properly. If it is
- -- not a controlling argument, the 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);
- end loop;
+ else
+ -- If this is a dispatching call that is itself the
+ -- controlling argument of an enclosing call, the
+ -- nominal subtype of the object that replaces it must
+ -- be classwide, so that dispatching will take place
+ -- properly. If it is not a controlling argument, the
+ -- 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);
+ end loop;
- if Is_Controlling_Formal (F) then
- Temp_Typ := Class_Wide_Type (Typ);
+ if Is_Controlling_Formal (F) then
+ Temp_Typ := Class_Wide_Type (Typ);
+ end if;
end if;
end if;
- end if;
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Obj,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Constant_Present => True,
- Expression => Relocate_Node (N));
- Set_Assignment_OK (Decl);
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Obj,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (N));
+ Set_Assignment_OK (Decl);
+
+ Insert_Actions (N, New_List (Decl));
+ Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
+ end;
- Insert_Actions (N, New_List (Decl));
- Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
- end;
+ else
+ -- If stack-checking is not enabled, increment serial number
+ -- for internal names, so that subsequent symbols are consistent
+ -- with and without stack-checking.
+
+ Synchronize_Serial_Number;
+
+ -- Now we can expand the call with consistent symbol names
+
+ Expand_Call (N);
+ end if;
-- Normal case, expand the call
-- 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
-- Create new exception handler
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
Excep_Handlers := No_List;
else
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_RTE (Root_Type (Etype (F)), RE_Address) then
+ if Is_Descendent_Of_Address (Etype (F)) then
Set_Is_Pure (Spec_Id, False);
if Spec_Id /= Body_Id then
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
end;
end if;
+ 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.
+
+ if Is_List_Member (N)
+ and then Present (Parent (List_Containing (N)))
+ and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
+ then
+ Add_Discriminal_Declarations
+ (Declarations (N), Scop, Name_uObject, Loc);
+ 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.
+
+ Next_Op := Next_Protected_Operation (N);
+
+ if Present (Next_Op) then
+ Dec := Parent (Base_Type (Scop));
+ Set_Privals (Dec, Next_Op, Loc);
+ Set_Discriminals (Dec);
+ end if;
+ end if;
+
-- Clear out statement list for stubbed procedure
if Present (Corresponding_Spec (N)) then
end if;
end if;
- Scop := Scope (Spec_Id);
-
-- 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
-- ...
end;
end if;
- -- 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)))
- and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
- then
- Add_Discriminal_Declarations
- (Declarations (N), Scop, Name_uObject, Loc);
- 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.
-
- Next_Op := Next_Protected_Operation (N);
-
- if Present (Next_Op) then
- Dec := Parent (Base_Type (Scop));
- Set_Privals (Dec, Next_Op, Loc);
- Set_Discriminals (Dec);
- end if;
- end if;
-
-- If subprogram contains a parameterless recursive call, then we may
-- have an infinite recursion, so see if we can generate code to check
-- for this possibility if storage checks are not suppressed.
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
+ -- 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)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
and then Is_Protected_Type (Scop)
then
- if No (Protected_Body_Subprogram (Subp)) then
+ if No (Protected_Body_Subprogram (Subp))
+ and then not Is_Eliminated (Subp)
+ then
Prot_Decl :=
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);