Skip to content

R
riscv-gcc-1
Commit d4817e3f by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent and the… 

exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent and the derived type are of the same kind.

2008-05-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb (Expand_Call): Add guard to ensure that both the parent
	and the derived type are of the same kind.
	(Expand_Call): Generate type conversions for actuals of
	record or array types when the parent and the derived types differ in
	size and/or packed status.

From-SVN: r135624
parent 4f469be3
Showing with 93 additions and 60 deletions
gcc/ada/exp_ch6.adb
...@@ -2641,77 +2641,110 @@ package body Exp_Ch6 is ...@@ -2641,77 +2641,110 @@ package body Exp_Ch6 is
("cannot call abstract subprogram &!", Name (N), Parent_Subp); ("cannot call abstract subprogram &!", Name (N), Parent_Subp);
end if; end if;
-- Add an explicit conversion for parameter of the derived type. -- Inspect all formals of derived subprogram Subp. Compare parameter
-- This is only done for scalar and access in-parameters. Others -- types with the parent subprogram and check whether an actual may
-- have been expanded in expand_actuals. -- need a type conversion to the corresponding formal of the parent
-- subprogram.
Formal := First_Formal (Subp); -- Not clear whether intrinsic subprograms need such conversions. ???
Parent_Formal := First_Formal (Parent_Subp);
Actual := First_Actual (N);
-- It is not clear that conversion is needed for intrinsic
-- subprograms, but it certainly is for those that are user-
-- defined, and that can be inherited on derivation, namely
-- unchecked conversion and deallocation.
-- General case needs study ???
if not Is_Intrinsic_Subprogram (Parent_Subp) if not Is_Intrinsic_Subprogram (Parent_Subp)
or else Is_Generic_Instance (Parent_Subp) or else Is_Generic_Instance (Parent_Subp)
then then
while Present (Formal) loop declare
if Etype (Formal) /= Etype (Parent_Formal) procedure Convert (Act : Node_Id; Typ : Entity_Id);
and then Is_Scalar_Type (Etype (Formal)) -- Rewrite node Act as a type conversion of Act to Typ. Analyze
and then Ekind (Formal) = E_In_Parameter -- and resolve the newly generated construct.
and then
not Subtypes_Statically_Match
(Etype (Parent_Formal), Etype (Actual))
and then not Raises_Constraint_Error (Actual)
then
Rewrite (Actual,
OK_Convert_To (Etype (Parent_Formal),
Relocate_Node (Actual)));
Analyze (Actual); -------------
Resolve (Actual, Etype (Parent_Formal)); -- Convert --
Enable_Range_Check (Actual); -------------
elsif Is_Access_Type (Etype (Formal)) procedure Convert (Act : Node_Id; Typ : Entity_Id) is
and then Base_Type (Etype (Parent_Formal)) /= begin
Base_Type (Etype (Actual)) Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
then Analyze (Act);
if Ekind (Formal) /= E_In_Parameter then Resolve (Act, Typ);
Rewrite (Actual, end Convert;
Convert_To (Etype (Parent_Formal),
Relocate_Node (Actual))); -- Local variables
Analyze (Actual); Actual_Typ : Entity_Id;
Resolve (Actual, Etype (Parent_Formal)); Formal_Typ : Entity_Id;
Parent_Typ : Entity_Id;
elsif
Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type begin
and then Designated_Type (Etype (Parent_Formal)) Actual := First_Actual (N);
/= Formal := First_Formal (Subp);
Designated_Type (Etype (Actual)) Parent_Formal := First_Formal (Parent_Subp);
and then not Is_Controlling_Formal (Formal) while Present (Formal) loop
Actual_Typ := Etype (Actual);
Formal_Typ := Etype (Formal);
Parent_Typ := Etype (Parent_Formal);
-- For an IN parameter of a scalar type, the parent formal
-- type and derived formal type differ or the parent formal
-- type and actual type do not match statically.
if Is_Scalar_Type (Formal_Typ)
and then Ekind (Formal) = E_In_Parameter
and then Formal_Typ /= Parent_Typ
and then
not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
and then not Raises_Constraint_Error (Actual)
then then
-- This unchecked conversion is not necessary unless Convert (Actual, Parent_Typ);
-- inlining is enabled, because in that case the type Enable_Range_Check (Actual);
-- mismatch may become visible in the body about to be
-- inlined.
Rewrite (Actual, -- For access types, the parent formal type and actual type
Unchecked_Convert_To (Etype (Parent_Formal), -- differ.
Relocate_Node (Actual)));
Analyze (Actual); elsif Is_Access_Type (Formal_Typ)
Resolve (Actual, Etype (Parent_Formal)); and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
then
if Ekind (Formal) /= E_In_Parameter then
Convert (Actual, Parent_Typ);
elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
and then Designated_Type (Parent_Typ) /=
Designated_Type (Actual_Typ)
and then not Is_Controlling_Formal (Formal)
then
-- This unchecked conversion is not necessary unless
-- inlining is enabled, because in that case the type
-- mismatch may become visible in the body about to be
-- inlined.
Rewrite (Actual,
Unchecked_Convert_To (Parent_Typ,
Relocate_Node (Actual)));
Analyze (Actual);
Resolve (Actual, Parent_Typ);
end if;
-- For array and record types, the parent formal type and
-- derived formal type have different sizes or pragma Pack
-- status.
elsif ((Is_Array_Type (Formal_Typ)
and then Is_Array_Type (Parent_Typ))
or else
(Is_Record_Type (Formal_Typ)
and then Is_Record_Type (Parent_Typ)))
and then
(Esize (Formal_Typ) /= Esize (Parent_Typ)
or else Has_Pragma_Pack (Formal_Typ) /=
Has_Pragma_Pack (Parent_Typ))
then
Convert (Actual, Parent_Typ);
end if; end if;
end if;
Next_Formal (Formal); Next_Actual (Actual);
Next_Formal (Parent_Formal); Next_Formal (Formal);
Next_Actual (Actual); Next_Formal (Parent_Formal);
end loop; end loop;
end;
end if; end if;
Orig_Subp := Subp; Orig_Subp := Subp;
...@@ -2744,7 +2777,7 @@ package body Exp_Ch6 is ...@@ -2744,7 +2777,7 @@ package body Exp_Ch6 is
-- Handle case of access to protected subprogram type -- Handle case of access to protected subprogram type
if Is_Access_Protected_Subprogram_Type if Is_Access_Protected_Subprogram_Type
(Base_Type (Etype (Prefix (Name (N))))) (Base_Type (Etype (Prefix (Name (N)))))
then then
-- If this is a call through an access to protected operation, -- If this is a call through an access to protected operation,
-- the prefix has the form (object'address, operation'access). -- the prefix has the form (object'address, operation'access).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment