with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
-- 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).
+ -- For nonscalar objects that are possibly unaligned, add call by copy code
+ -- (copy in for IN and IN OUT, copy out for OUT and IN OUT).
--
-- For OUT and IN OUT parameters, add predicate checks after the call
-- based on the predicates of the actual type.
Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
+ -- The new code will be properly analyzed below and the setting of
+ -- the Do_Range_Check flag recomputed so remove the obsolete one.
+
+ Set_Do_Range_Check (Actual, False);
+
if Nkind (Actual) = N_Type_Conversion then
+ Set_Do_Range_Check (Expression (Actual), False);
+
V_Typ := Etype (Expression (Actual));
-- If the formal is an (in-)out parameter, capture the name
Init := New_Occurrence_Of (Var, Loc);
end if;
+ -- Access types are passed in without checks, but if a copy-back is
+ -- required for a null-excluding check on an in-out or out parameter,
+ -- then the initial value is that of the actual.
+
+ elsif Is_Access_Type (E_Formal)
+ and then Can_Never_Be_Null (Etype (Actual))
+ and then not Can_Never_Be_Null (E_Formal)
+ then
+ Init := New_Occurrence_Of (Var, Loc);
+
else
Init := Empty;
end if;
Type_Access_Level (E_Formal))));
else
+ if Is_Access_Type (E_Formal)
+ and then Can_Never_Be_Null (Etype (Actual))
+ and then not Can_Never_Be_Null (E_Formal)
+ then
+ Append_To (Post_Call,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Temp, Loc),
+ Right_Opnd => Make_Null (Loc)),
+ Reason => CE_Access_Check_Failed));
+ end if;
+
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Var_Id : Entity_Id;
begin
+ -- Generate range check if required
+
+ if Do_Range_Check (Actual) then
+ Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+ end if;
+
+ -- If there is a type conversion in the actual, it will be reinstated
+ -- below, the new instance will be properly analyzed and the setting
+ -- of the Do_Range_Check flag recomputed so remove the obsolete one.
+
+ if Nkind (Actual) = N_Type_Conversion then
+ Set_Do_Range_Check (Expression (Actual), False);
+ end if;
+
-- Copy the value of the validation variable back into the object
-- being validated.
Apply_Constraint_Check (Actual, E_Formal);
-- Out parameter case. No constraint checks on access type
- -- RM 6.4.1 (13)
+ -- RM 6.4.1 (13), but on return a null-excluding check may be
+ -- required (see below).
elsif Is_Access_Type (E_Formal) then
null;
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code;
- -- If a non-scalar actual is possibly bit-aligned, we need a copy
+ -- If a nonscalar actual is possibly bit-aligned, we need a copy
-- because the back-end cannot cope with such objects. In other
-- cases where alignment forces a copy, the back-end generates
-- it properly. It should not be generated unconditionally in the
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
- -- conversion" errors.
+ -- conversion" errors, but null-excluding checks on return may be
+ -- required.
elsif Is_Access_Type (E_Formal)
- and then not Same_Type (E_Formal, E_Actual)
and then not Is_Tagged_Type (Designated_Type (E_Formal))
+ and then (not Same_Type (E_Formal, E_Actual)
+ or else (Can_Never_Be_Null (E_Actual)
+ and then not Can_Never_Be_Null (E_Formal)))
then
Add_Call_By_Copy_Code;
(Ekind (Formal) = E_In_Out_Parameter
and then not In_Subrange_Of (E_Actual, E_Formal)))
then
- -- Perhaps the setting back to False should be done within
- -- Add_Call_By_Copy_Code, since it could get set on other
- -- cases occurring above???
-
- if Do_Range_Check (Actual) then
- Set_Do_Range_Check (Actual, False);
- end if;
-
Add_Call_By_Copy_Code;
end if;
-- Processing for IN parameters
else
+ -- Generate range check if required
+
+ if Do_Range_Check (Actual) then
+ Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+ end if;
+
-- For IN parameters in the bit-packed array case, we expand an
-- indexed component (the circuit in Exp_Ch4 deliberately left
-- indexed components appearing as actuals untouched, so that
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code;
- -- If a non-scalar actual is possibly unaligned, we need a copy
+ -- If a nonscalar actual is possibly unaligned, we need a copy
elsif Is_Possibly_Unaligned_Object (Actual)
and then not Represented_As_Scalar (Etype (Formal))
-- Adds invariant checks for every intermediate type between the range
-- of a view converted argument to its ancestor (from parent to child).
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
+ -- Try to constant-fold a predicate check, which often enough is a
+ -- simple arithmetic expression that can be computed statically if
+ -- its argument is static. This cleans up the output of CCG, even
+ -- though useless predicate checks will be generally removed by
+ -- back-end optimizations.
+
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from an untagged formal derived
-- type inherits from the original parent, not from the actual. The
function In_Unfrozen_Instance (E : Entity_Id) return Boolean;
-- Return true if E comes from an instance that is not yet frozen
+ function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean;
+ -- Return True when E is a class-wide interface type or an access to
+ -- a class-wide interface type.
+
function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
-- Determine if Subp denotes a non-dispatching call to a Deep routine
end if;
end Add_View_Conversion_Invariants;
+ -----------------------------
+ -- Can_Fold_Predicate_Call --
+ -----------------------------
+
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
+ Actual : Node_Id;
+
+ function May_Fold (N : Node_Id) return Traverse_Result;
+ -- The predicate expression is foldable if it only contains operators
+ -- and literals. During this check, we also replace occurrences of
+ -- the formal of the constructed predicate function with the static
+ -- value of the actual. This is done on a copy of the analyzed
+ -- expression for the predicate.
+
+ --------------
+ -- May_Fold --
+ --------------
+
+ function May_Fold (N : Node_Id) return Traverse_Result is
+ begin
+ case Nkind (N) is
+ when N_Binary_Op
+ | N_Unary_Op
+ =>
+ return OK;
+
+ when N_Expanded_Name
+ | N_Identifier
+ =>
+ if Ekind (Entity (N)) = E_In_Parameter
+ and then Entity (N) = First_Entity (P)
+ then
+ Rewrite (N, New_Copy (Actual));
+ Set_Is_Static_Expression (N);
+ return OK;
+
+ elsif Ekind (Entity (N)) = E_Enumeration_Literal then
+ return OK;
+
+ else
+ return Abandon;
+ end if;
+
+ when N_Case_Expression
+ | N_If_Expression
+ =>
+ return OK;
+
+ when N_Integer_Literal =>
+ return OK;
+
+ when others =>
+ return Abandon;
+ end case;
+ end May_Fold;
+
+ function Try_Fold is new Traverse_Func (May_Fold);
+
+ -- Other lLocal variables
+
+ Subt : constant Entity_Id := Etype (First_Entity (P));
+ Aspect : Node_Id;
+ Pred : Node_Id;
+
+ -- Start of processing for Can_Fold_Predicate_Call
+
+ begin
+ -- Folding is only interesting if the actual is static and its type
+ -- has a Dynamic_Predicate aspect. For CodePeer we preserve the
+ -- function call.
+
+ Actual := First (Parameter_Associations (Call_Node));
+ Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate);
+
+ -- If actual is a declared constant, retrieve its value
+
+ if Is_Entity_Name (Actual)
+ and then Ekind (Entity (Actual)) = E_Constant
+ then
+ Actual := Constant_Value (Entity (Actual));
+ end if;
+
+ if No (Actual)
+ or else Nkind (Actual) /= N_Integer_Literal
+ or else not Has_Dynamic_Predicate_Aspect (Subt)
+ or else No (Aspect)
+ or else CodePeer_Mode
+ then
+ return False;
+ end if;
+
+ -- Retrieve the analyzed expression for the predicate
+
+ Pred := New_Copy_Tree (Expression (Aspect));
+
+ if Try_Fold (Pred) = OK then
+ Rewrite (Call_Node, Pred);
+ Analyze_And_Resolve (Call_Node, Standard_Boolean);
+ return True;
+
+ -- Otherwise continue the expansion of the function call
+
+ else
+ return False;
+ end if;
+ end Can_Fold_Predicate_Call;
+
---------------------------
-- Inherited_From_Formal --
---------------------------
return False;
end In_Unfrozen_Instance;
+ ----------------------------------
+ -- Is_Class_Wide_Interface_Type --
+ ----------------------------------
+
+ function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is
+ DDT : Entity_Id;
+ Typ : Entity_Id := E;
+
+ begin
+ if Has_Non_Limited_View (Typ) then
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if Ekind (Typ) = E_Anonymous_Access_Type then
+ DDT := Directly_Designated_Type (Typ);
+
+ if Has_Non_Limited_View (DDT) then
+ DDT := Non_Limited_View (DDT);
+ end if;
+
+ return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT);
+ else
+ return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ);
+ end if;
+ end Is_Class_Wide_Interface_Type;
+
-------------------------
-- Is_Direct_Deep_Call --
-------------------------
end;
end if;
+ -- if this is a call to a predicate function, try to constant
+ -- fold it.
+
+ if Nkind (Call_Node) = N_Function_Call
+ and then Is_Entity_Name (Name (Call_Node))
+ and then Is_Predicate_Function (Subp)
+ and then Can_Fold_Predicate_Call (Subp)
+ then
+ return;
+ end if;
+
if Modify_Tree_For_C
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
Actual := First_Actual (Call_Node);
Param_Count := 1;
while Present (Formal) loop
-
- -- Generate range check if required
-
- if Do_Range_Check (Actual)
- and then Ekind (Formal) = E_In_Parameter
- then
- Generate_Range_Check
- (Actual, Etype (Formal), CE_Range_Check_Failed);
- end if;
-
-- Prepare to examine current entry
Prev := Actual;
CW_Interface_Formals_Present :=
CW_Interface_Formals_Present
- or else
- (Is_Class_Wide_Type (Etype (Formal))
- and then Is_Interface (Etype (Etype (Formal))))
- or else
- (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- and then Is_Class_Wide_Type (Directly_Designated_Type
- (Etype (Etype (Formal))))
- and then Is_Interface (Directly_Designated_Type
- (Etype (Etype (Formal)))));
+ or else Is_Class_Wide_Interface_Type (Etype (Formal));
-- Create possible extra actual for constrained case. Usually, the
-- extra actual is of the form actual'constrained, but since this
-- or IN OUT parameter. We do reset the Is_Known_Valid flag
-- since the subprogram could have returned in invalid value.
- if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
- and then Is_Assignable (Ent)
- then
+ if Is_Assignable (Ent) then
Sav := Last_Assignment (Ent);
Kill_Current_Values (Ent);
Set_Last_Assignment (Ent, Sav);
if not Is_Inlined (Subp) then
null;
- -- Frontend inlining of expression functions (performed also when
- -- backend inlining is enabled).
+ -- Front-end inlining of expression functions (performed also when
+ -- back-end inlining is enabled).
elsif Is_Inlinable_Expression_Function (Subp) then
Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
Analyze (N);
return;
- -- Handle frontend inlining
+ -- Handle front-end inlining
elsif not Back_End_Inlining then
Inlined_Subprogram : declare
end if;
end Inlined_Subprogram;
- -- Back end inlining: let the back end handle it
-
- elsif No (Unit_Declaration_Node (Subp))
- or else Nkind (Unit_Declaration_Node (Subp)) /=
- N_Subprogram_Declaration
- or else No (Body_To_Inline (Unit_Declaration_Node (Subp)))
- or else Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) in
- N_Entity
- then
- Add_Inlined_Body (Subp, Call_Node);
-
- -- If the inlined call appears within an instantiation and some
- -- level of optimization is required, ensure that the enclosing
- -- instance body is available so that the back-end can actually
- -- perform the inlining.
-
- if In_Instance
- and then Comes_From_Source (Subp)
- and then Optimization_Level > 0
- then
- declare
- Decl : Node_Id;
- Inst : Entity_Id;
- Inst_Node : Node_Id;
-
- begin
- Inst := Scope (Subp);
-
- -- Find enclosing instance
-
- while Present (Inst) and then Inst /= Standard_Standard loop
- exit when Is_Generic_Instance (Inst);
- Inst := Scope (Inst);
- end loop;
-
- if Present (Inst)
- and then Is_Generic_Instance (Inst)
- and then not Is_Inlined (Inst)
- then
- Set_Is_Inlined (Inst);
- Decl := Unit_Declaration_Node (Inst);
-
- -- Do not add a pending instantiation if the body exits
- -- already, or if the instance is a compilation unit, or
- -- the instance node is missing.
-
- if Present (Corresponding_Body (Decl))
- or else Nkind (Parent (Decl)) = N_Compilation_Unit
- or else No (Next (Decl))
- then
- null;
-
- else
- -- The instantiation node usually follows the package
- -- declaration for the instance. If the generic unit
- -- has aspect specifications, they are transformed
- -- into pragmas in the instance, and the instance node
- -- appears after them.
-
- Inst_Node := Next (Decl);
-
- while Nkind (Inst_Node) /= N_Package_Instantiation loop
- Inst_Node := Next (Inst_Node);
- end loop;
-
- Add_Pending_Instantiation (Inst_Node, Decl);
- end if;
- end if;
- end;
- end if;
-
- -- Front end expansion of simple functions returning unconstrained
+ -- Front-end expansion of simple functions returning unconstrained
-- types (see Check_And_Split_Unconstrained_Function). Note that the
- -- case of a simple renaming (Body_To_Inline in N_Entity above, see
+ -- case of a simple renaming (Body_To_Inline in N_Entity below, see
-- also Build_Renamed_Body) cannot be expanded here because this may
-- give rise to order-of-elaboration issues for the types of the
-- parameters of the subprogram, if any.
- else
+ elsif Present (Unit_Declaration_Node (Subp))
+ and then Nkind (Unit_Declaration_Node (Subp)) =
+ N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Unit_Declaration_Node (Subp)))
+ and then
+ Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in
+ N_Entity
+ then
Expand_Inlined_Call (Call_Node, Subp, Orig_Subp);
+
+ -- Back-end inlining either if optimization is enabled or the call is
+ -- required to be inlined.
+
+ elsif Optimization_Level > 0
+ or else Has_Pragma_Inline_Always (Subp)
+ then
+ Add_Inlined_Body (Subp, Call_Node);
end if;
end if;
Set_Comes_From_Extended_Return_Statement (Return_Stmt);
Rewrite (N, Result);
- Analyze (N, Suppress => All_Checks);
+
+ declare
+ T : constant Entity_Id := Etype (Ret_Obj_Id);
+ begin
+ Analyze (N, Suppress => All_Checks);
+
+ -- In some cases, analysis of N can set the Etype of an N_Identifier
+ -- to a subtype of the Etype of the Entity of the N_Identifier, which
+ -- gigi doesn't like. Reset the Etypes correctly here.
+
+ if Nkind (Expression (Return_Stmt)) = N_Identifier
+ and then Entity (Expression (Return_Stmt)) = Ret_Obj_Id
+ then
+ Set_Etype (Ret_Obj_Id, T);
+ Set_Etype (Expression (Return_Stmt), T);
+ end if;
+ end;
end Expand_N_Extended_Return_Statement;
----------------------------
end;
end if;
- -- If we are returning an object that may not be bit-aligned, then copy
- -- the value into a temporary first. This copy may need to expand to a
- -- loop of component operations.
+ -- If we are returning a nonscalar object that is possibly unaligned,
+ -- then copy the value into a temporary first. This copy may need to
+ -- expand to a loop of component operations.
if Is_Possibly_Unaligned_Slice (Exp)
- or else Is_Possibly_Unaligned_Object (Exp)
+ or else (Is_Possibly_Unaligned_Object (Exp)
+ and then not Represented_As_Scalar (Etype (Exp)))
then
declare
ExpR : constant Node_Id := Relocate_Node (Exp);
-- since it is already attached on the related finalization master.
-- Here and in related routines, we must examine the full view of the
- -- type, because the view at the point of call may differ from that
- -- that in the function body, and the expansion mechanism depends on
+ -- type, because the view at the point of call may differ from the
+ -- one in the function body, and the expansion mechanism depends on
-- the characteristics of the full view.
- if Is_Constrained (Underlying_Type (Result_Subt))
- and then not Needs_Finalization (Underlying_Type (Result_Subt))
- then
+ if Needs_BIP_Alloc_Form (Function_Id) then
+ Temp_Init := Empty;
+
+ -- Case of a user-defined storage pool. Pass an allocation parameter
+ -- indicating that the function should allocate its result in the
+ -- pool, and pass the pool. Use 'Unrestricted_Access because the
+ -- pool may not be aliased.
+
+ if Present (Associated_Storage_Pool (Acc_Type)) then
+ Alloc_Form := User_Storage_Pool;
+ Pool :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Associated_Storage_Pool (Acc_Type), Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ -- No user-defined pool; pass an allocation parameter indicating that
+ -- the function should allocate its result on the heap.
+
+ else
+ Alloc_Form := Global_Heap;
+ Pool := Make_Null (No_Location);
+ end if;
+
+ -- The caller does not provide the return object in this case, so we
+ -- have to pass null for the object access actual.
+
+ Return_Obj_Actual := Empty;
+
+ else
-- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
-- result subtype of the called function. The call to the function
-- perform the allocation of the return object, so we pass parameters
-- indicating that.
- else
- Temp_Init := Empty;
-
- -- Case of a user-defined storage pool. Pass an allocation parameter
- -- indicating that the function should allocate its result in the
- -- pool, and pass the pool. Use 'Unrestricted_Access because the
- -- pool may not be aliased.
-
- if Present (Associated_Storage_Pool (Acc_Type)) then
- Alloc_Form := User_Storage_Pool;
- Pool :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Associated_Storage_Pool (Acc_Type), Loc),
- Attribute_Name => Name_Unrestricted_Access);
-
- -- No user-defined pool; pass an allocation parameter indicating that
- -- the function should allocate its result on the heap.
-
- else
- Alloc_Form := Global_Heap;
- Pool := Make_Null (No_Location);
- end if;
-
- -- The caller does not provide the return object in this case, so we
- -- have to pass null for the object access actual.
-
- Return_Obj_Actual := Empty;
end if;
-- Declare the temp object
function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
begin
- -- A build-in-place function needs to know which allocation form to
- -- use when:
- --
- -- 1) The result subtype is unconstrained. In this case, depending on
- -- the context of the call, the object may need to be created in the
- -- secondary stack, the heap, or a user-defined storage pool.
- --
- -- 2) The result subtype is tagged. In this case the function call may
- -- dispatch on result and thus needs to be treated in the same way as
- -- calls to functions with class-wide results, because a callee that
- -- can be dispatched to may have any of various result subtypes, so
- -- if any of the possible callees would require an allocation form to
- -- be passed then they all do.
- --
- -- 3) The result subtype needs finalization actions. In this case, based
- -- on the context of the call, the object may need to be created at
- -- the caller site, in the heap, or in a user-defined storage pool.
-
- return
- not Is_Constrained (Func_Typ)
- or else Is_Tagged_Type (Func_Typ)
- or else Needs_Finalization (Func_Typ);
+ return Requires_Transient_Scope (Func_Typ);
end Needs_BIP_Alloc_Form;
--------------------------------------
projects / thirdparty / gcc.git / blobdiff