Skip to content

R
riscv-gcc-1
Commit 3f433bc0 by Ed Schonberg Committed by Arnaud Charlet
Options

sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util. 

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util.
	* sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks):
	Moved here, so it can be shared with the resolution of 'Update,
	whose argument shares some features with aggregates.
	* sem_attr.adb (Resolve_Attribute, case 'Update): Apply
	Aggregate_Constraint_Checks with the expression of each
	association, so that the Do_Range_Check flag is set when needed.

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing):  If the container
	type is a derived type, the value of the inherited  aspect is
	the Reference operation declared for the parent type. However,
	Reference is also a primitive operation of the new type, and
	the inherited operation has a different signature. We retrieve
	the right one from the list of primitive operations of the
	derived type.

From-SVN: r212786
parent 0439c912
Showing with 164 additions and 125 deletions
gcc/ada/ChangeLog
2014-07-18 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util.
* sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks):
Moved here, so it can be shared with the resolution of 'Update,
whose argument shares some features with aggregates.
* sem_attr.adb (Resolve_Attribute, case 'Update): Apply
Aggregate_Constraint_Checks with the expression of each
association, so that the Do_Range_Check flag is set when needed.
2014-07-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Try_Container_Indexing): If the container
type is a derived type, the value of the inherited aspect is
the Reference operation declared for the parent type. However,
Reference is also a primitive operation of the new type, and
the inherited operation has a different signature. We retrieve
the right one from the list of primitive operations of the
derived type.
2014-07-18 Vincent Celier <celier@adacore.com>
* debug.adb: Update comment.
......
gcc/ada/sem_aggr.adb
......@@ -408,134 +408,11 @@ package body Sem_Aggr is
-- The bounds of the aggregate itype are cooked up to look reasonable
-- (in this particular case the bounds will be 1 .. 2).
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id);
-- Checks expression Exp against subtype Check_Typ. If Exp is an
-- aggregate and Check_Typ a constrained record type with discriminants,
-- we generate the appropriate discriminant checks. If Exp is an array
-- aggregate then emit the appropriate length checks. If Exp is a scalar
-- type, or a string literal, Exp is changed into Check_Typ'(Exp) to
-- ensure that range checks are performed at run time.
procedure Make_String_Into_Aggregate (N : Node_Id);
-- A string literal can appear in a context in which a one dimensional
-- array of characters is expected. This procedure simply rewrites the
-- string as an aggregate, prior to resolution.
---------------------------------
-- Aggregate_Constraint_Checks --
---------------------------------
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id)
is
Exp_Typ : constant Entity_Id := Etype (Exp);
begin
if Raises_Constraint_Error (Exp) then
return;
end if;
-- Ada 2005 (AI-230): Generate a conversion to an anonymous access
-- component's type to force the appropriate accessibility checks.
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
if Is_Access_Type (Check_Typ)
and then ((Is_Local_Anonymous_Access (Check_Typ))
or else (Can_Never_Be_Null (Check_Typ)
and then not Can_Never_Be_Null (Exp_Typ)))
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- This is really expansion activity, so make sure that expansion is
-- on and is allowed. In GNATprove mode, we also want check flags to
-- be added in the tree, so that the formal verification can rely on
-- those to be present. In GNATprove mode for formal verification, some
-- treatment typically only done during expansion needs to be performed
-- on the tree, but it should not be applied inside generics. Otherwise,
-- this breaks the name resolution mechanism for generic instances.
if not Expander_Active
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
end if;
-- First check if we have to insert discriminant checks
if Has_Discriminants (Exp_Typ) then
Apply_Discriminant_Check (Exp, Check_Typ);
-- Next emit length checks for array aggregates
elsif Is_Array_Type (Exp_Typ) then
Apply_Length_Check (Exp, Check_Typ);
-- Finally emit scalar and string checks. If we are dealing with a
-- scalar literal we need to check by hand because the Etype of
-- literals is not necessarily correct.
elsif Is_Scalar_Type (Exp_Typ)
and then Compile_Time_Known_Value (Exp)
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
elsif not Range_Checks_Suppressed (Check_Typ) then
Apply_Scalar_Range_Check (Exp, Check_Typ);
end if;
-- Verify that target type is also scalar, to prevent view anomalies
-- in instantiations.
elsif (Is_Scalar_Type (Exp_Typ)
or else Nkind (Exp) = N_String_Literal)
and then Is_Scalar_Type (Check_Typ)
and then Exp_Typ /= Check_Typ
then
if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
then
-- If expression is a constant, it is worthwhile checking whether
-- it is a bound of the type.
if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
then
return;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
end if;
end Aggregate_Constraint_Checks;
------------------------
-- Array_Aggr_Subtype --
------------------------
......
gcc/ada/sem_attr.adb
......@@ -10802,6 +10802,7 @@ package body Sem_Attr is
Typ : constant Entity_Id := Etype (Prefix (N));
Assoc : Node_Id;
Comp : Node_Id;
Expr : Node_Id;
begin
-- Set the Etype of the aggregate to that of the prefix, even
......@@ -10814,12 +10815,14 @@ package body Sem_Attr is
Resolve (Prefix (N), Typ);
-- For an array type, resolve expressions with the component
-- type of the array.
-- type of the array, and apply constraint checks when needed.
if Is_Array_Type (Typ) then
Assoc := First (Component_Associations (Aggr));
while Present (Assoc) loop
Resolve (Expression (Assoc), Component_Type (Typ));
Expr := Expression (Assoc);
Resolve (Expr, Component_Type (Typ));
Aggregate_Constraint_Checks (Expr, Component_Type (Typ));
-- The choices in the association are static constants,
-- or static aggregates each of whose components belongs
......
gcc/ada/sem_ch4.adb
......@@ -7020,6 +7020,16 @@ package body Sem_Ch4 is
else
return False;
end if;
-- If the container type is a derived type, the value of the inherited
-- aspect is the Reference operation declared for the parent type.
-- However, Reference is also a primitive operation of the type, and
-- the inherited operation has a different signature. We retrieve the
-- right one from the list of primitive operations of the derived type.
elsif Is_Derived_Type (Etype (Prefix)) then
Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name));
Func_Name := New_Occurrence_Of (Func, Loc);
end if;
Assoc := New_List (Relocate_Node (Prefix));
......
gcc/ada/sem_util.adb
......@@ -52,6 +52,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Warn; use Sem_Warn;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
......@@ -474,6 +475,123 @@ package body Sem_Util is
V = 64;
end Addressable;
---------------------------------
-- Aggregate_Constraint_Checks --
---------------------------------
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id)
is
Exp_Typ : constant Entity_Id := Etype (Exp);
begin
if Raises_Constraint_Error (Exp) then
return;
end if;
-- Ada 2005 (AI-230): Generate a conversion to an anonymous access
-- component's type to force the appropriate accessibility checks.
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
if Is_Access_Type (Check_Typ)
and then ((Is_Local_Anonymous_Access (Check_Typ))
or else (Can_Never_Be_Null (Check_Typ)
and then not Can_Never_Be_Null (Exp_Typ)))
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- This is really expansion activity, so make sure that expansion is
-- on and is allowed. In GNATprove mode, we also want check flags to
-- be added in the tree, so that the formal verification can rely on
-- those to be present. In GNATprove mode for formal verification, some
-- treatment typically only done during expansion needs to be performed
-- on the tree, but it should not be applied inside generics. Otherwise,
-- this breaks the name resolution mechanism for generic instances.
if not Expander_Active
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
end if;
-- First check if we have to insert discriminant checks
if Has_Discriminants (Exp_Typ) then
Apply_Discriminant_Check (Exp, Check_Typ);
-- Next emit length checks for array aggregates
elsif Is_Array_Type (Exp_Typ) then
Apply_Length_Check (Exp, Check_Typ);
-- Finally emit scalar and string checks. If we are dealing with a
-- scalar literal we need to check by hand because the Etype of
-- literals is not necessarily correct.
elsif Is_Scalar_Type (Exp_Typ)
and then Compile_Time_Known_Value (Exp)
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
elsif not Range_Checks_Suppressed (Check_Typ) then
Apply_Scalar_Range_Check (Exp, Check_Typ);
end if;
-- Verify that target type is also scalar, to prevent view anomalies
-- in instantiations.
elsif (Is_Scalar_Type (Exp_Typ)
or else Nkind (Exp) = N_String_Literal)
and then Is_Scalar_Type (Check_Typ)
and then Exp_Typ /= Check_Typ
then
if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
then
-- If expression is a constant, it is worthwhile checking whether
-- it is a bound of the type.
if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
or else
(Is_Entity_Name (Type_High_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
then
return;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- Could use a comment on this case ???
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
end if;
end Aggregate_Constraint_Checks;
-----------------------
-- Alignment_In_Bits --
-----------------------
......
gcc/ada/sem_util.ads
......@@ -91,6 +91,17 @@ package Sem_Util is
-- Returns True if the value of V is the word size of an addressable
-- factor of the word size (typically 8, 16, 32 or 64).
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id);
-- Checks expression Exp against subtype Check_Typ. If Exp is an aggregate
-- and Check_Typ a constrained record type with discriminants, we generate
-- the appropriate discriminant checks. If Exp is an array aggregate then
-- emit the appropriate length checks. If Exp is a scalar type, or a string
-- literal, Exp is changed into Check_Typ'(Exp) to ensure that range checks
-- are performed at run time. Also used for expressions in the argument of
-- 'Update, which shares some of the features of an aggregate.
function Alignment_In_Bits (E : Entity_Id) return Uint;
-- If the alignment of the type or object E is currently known to the
-- compiler, then this function returns the alignment value in bits.
......
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