+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.
-- 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 --
------------------------
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
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
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));
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;
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 --
-----------------------
-- 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.
projects / thirdparty / gcc.git / commitdiff
