+2012-10-02 Robert Dewar <dewar@adacore.com>
+
+ * sem_dim.adb: Minor code reorganization.
+ * sem_dim.ads: Add comment.
+
+2012-10-02 Robert Dewar <dewar@adacore.com>
+
+ * checks.ads, exp_ch4.adb, checks.adb
+ (Minimize_Eliminate_Overflow_Checks): Add Top_Level parameter to avoid
+ unnecessary conversions to Bignum.
+ Minor reformatting.
+
+2012-10-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Process_PPCs): Generate invariant checks for a
+ return value whose type is an access type and whose designated
+ type has invariants. Ditto for in-out parameters and in-parameters
+ of an access type.
+ * exp_ch3.adb (Build_Component_Invariant_Call): Add invariant check
+ for an access component whose designated type has invariants.
+
2012-10-01 Vincent Pucci <pucci@adacore.com>
* sem_aggr.adb (New_Copy_Tree_And_Copy_Dimensions): New routine.
-- Otherwise, we have a top level arithmetic operator node, and this
-- is where we commence the special processing for minimize/eliminate.
+ -- This is the case where we tell the machinery not to move into Bignum
+ -- mode at this top level (of course the top level operation will still
+ -- be in Bignum mode if either of its operands are of type Bignum).
- Minimize_Eliminate_Overflow_Checks (Op, Lo, Hi);
+ Minimize_Eliminate_Overflow_Checks (Op, Lo, Hi, Top_Level => True);
-- That call may but does not necessarily change the result type of Op.
-- It is the job of this routine to undo such changes, so that at the
Error_Msg_N
("\this will result in infinite recursion?", Parent (N));
Insert_Action (N,
- Make_Raise_Storage_Error
- (Sloc (N), Reason => SE_Infinite_Recursion));
+ Make_Raise_Storage_Error (Sloc (N),
+ Reason => SE_Infinite_Recursion));
- else
+ -- Here for normal case of predicate active.
+ else
-- If the predicate is a static predicate and the operand is
-- static, the predicate must be evaluated statically. If the
-- evaluation fails this is a static constraint error.
if Is_OK_Static_Expression (N) then
- if Present (Static_Predicate (Typ)) then
+ if Present (Static_Predicate (Typ)) then
if Eval_Static_Predicate_Check (N, Typ) then
return;
else
Error_Msg_NE
("static expression fails static predicate check on&",
- N, Typ);
+ N, Typ);
end if;
end if;
end if;
----------------------------------------
procedure Minimize_Eliminate_Overflow_Checks
- (N : Node_Id;
- Lo : out Uint;
- Hi : out Uint)
+ (N : Node_Id;
+ Lo : out Uint;
+ Hi : out Uint;
+ Top_Level : Boolean)
is
pragma Assert (Is_Signed_Integer_Type (Etype (N)));
OK : Boolean;
-- Used in call to Determine_Range
+ Bignum_Operands : Boolean;
+ -- Set True if one or more operands is already of type Bignum, meaning
+ -- that for sure (regardless of Top_Level setting) we are committed to
+ -- doing the operation in Bignum mode.
+
procedure Max (A : in out Uint; B : Uint);
-- If A is No_Uint, sets A to B, else to UI_Max (A, B);
-- Start of processing for Minimize_Eliminate_Overflow_Checks
begin
- -- Case where we do not have an arithmetic operator.
+ -- Case where we do not have an arithmetic operator
if not Is_Signed_Integer_Arithmetic_Op (N) then
-- that lies below us!)
else
- Minimize_Eliminate_Overflow_Checks (Right_Opnd (N), Rlo, Rhi);
+ Minimize_Eliminate_Overflow_Checks
+ (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
if Binary then
- Minimize_Eliminate_Overflow_Checks (Left_Opnd (N), Llo, Lhi);
+ Minimize_Eliminate_Overflow_Checks
+ (Left_Opnd (N), Llo, Lhi, Top_Level => False);
end if;
end if;
if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then
Lo := No_Uint;
Hi := No_Uint;
+ Bignum_Operands := True;
-- Otherwise compute result range
else
+ Bignum_Operands := False;
+
case Nkind (N) is
-- Absolute value
if Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
- -- In MINIMIZED mode, note that an overflow check is required
- -- Note that we know we don't have a Bignum, since Bignums only
- -- appear in Eliminated mode.
-
- if Check_Mode = Minimized then
+ -- OK, we are definitely outside the range of Long_Long_Integer. The
+ -- question is whether to move into Bignum mode, or remain the domain
+ -- of Long_Long_Integer, signalling that an overflow check is needed.
+
+ -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
+ -- the Bignum business. In ELIMINATED mode, we will normally move
+ -- into Bignum mode, but there is an exception if neither of our
+ -- operands is Bignum now, and we are at the top level (Top_Level
+ -- set True). In this case, there is no point in moving into Bignum
+ -- mode to prevent overflow if the caller will immediately convert
+ -- the Bignum value back to LLI with an overflow check. It's more
+ -- efficient to stay in LLI mode with an overflow check.
+
+ if Check_Mode = Minimized
+ or else (Top_Level and not Bignum_Operands)
+ then
Enable_Overflow_Check (N);
- -- Otherwise we are in ELIMINATED mode, switch to bignum
+ -- Since we are doing an overflow check, the result has to be in
+ -- Long_Long_Integer mode, so adjust the possible range to reflect
+ -- this. Note these calls also change No_Uint values from the top
+ -- level case to LLI bounds.
+
+ Max (Lo, LLLo);
+ Min (Hi, LLHi);
+
+ -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
else
pragma Assert (Check_Mode = Eliminated);
Name => New_Occurrence_Of (Fent, Loc),
Parameter_Associations => Args));
Analyze_And_Resolve (N, RTE (RE_Bignum));
+
+ -- Indicate result is Bignum mode
+
+ Lo := No_Uint;
+ Hi := No_Uint;
return;
end;
end if;
-- parameter is used to supply Sloc values for the constructed tree.
procedure Minimize_Eliminate_Overflow_Checks
- (N : Node_Id;
- Lo : out Uint;
- Hi : out Uint);
+ (N : Node_Id;
+ Lo : out Uint;
+ Hi : out Uint;
+ Top_Level : Boolean);
-- This is the main routine for handling MINIMIZED and ELIMINATED overflow
-- checks. On entry N is a node whose result is a signed integer subtype.
-- If the node is an artihmetic operation, then a range analysis is carried
--
-- Note that if Bignum values appear, the caller must take care of doing
-- the appropriate mark/release operation on the secondary stack.
+ --
+ -- Top_Level is used to avoid inefficient unnecessary transitions into the
+ -- Bignum domain. If Top_Level is True, it means that the caller will have
+ -- to convert any Bignum value back to Long_Long_Integer, checking that the
+ -- value is in range. This is the normal case for a top level operator in
+ -- a subexpression. There is no point in going into Bignum mode to avoid an
+ -- overflow just so we can check for overflow the next moment. For calls
+ -- from comparisons and membership tests, and for all recursive calls, we
+ -- do want to transition into the Bignum domain if necessary. Note that
+ -- this setting is only relevant in ELIMINATED mode.
-------------------------------------------------------
-- Control and Optimization of Range/Overflow Checks --
return Node_Id
is
Sel_Comp : Node_Id;
+ Typ : Entity_Id;
+ Call : Node_Id;
begin
Invariant_Found := True;
+ Typ := Etype (Comp);
+
Sel_Comp :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Object_Entity, Loc),
Selector_Name => New_Occurrence_Of (Comp, Loc));
- return
+ if Is_Access_Type (Typ) then
+ Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
+ Typ := Designated_Type (Typ);
+ end if;
+
+ Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of
- (Invariant_Procedure (Etype (Comp)), Loc),
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
Parameter_Associations => New_List (Sel_Comp));
+
+ if Is_Access_Type (Etype (Comp)) then
+ Call :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Make_Null (Loc),
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Object_Entity, Loc),
+ Selector_Name => New_Occurrence_Of (Comp, Loc))),
+ Then_Statements => New_List (Call));
+ end if;
+
+ return Call;
end Build_Component_Invariant_Call;
----------------------------
if Nkind (Decl) = N_Component_Declaration then
Id := Defining_Identifier (Decl);
- if Has_Invariants (Etype (Id)) then
+ if Has_Invariants (Etype (Id))
+ and then In_Open_Scopes (Scope (R_Type))
+ then
+ Append_To (Stmts, Build_Component_Invariant_Call (Id));
+
+ elsif Is_Access_Type (Etype (Id))
+ and then not Is_Access_Constant (Etype (Id))
+ and then Has_Invariants (Designated_Type (Etype (Id)))
+ and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
+ then
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
end if;
Build_Array_Init_Proc (Base, N);
end if;
- if Has_Invariants (Component_Type (Base)) then
-
- -- Generate component invariant checking procedure.
+ if Has_Invariants (Component_Type (Base))
+ and then In_Open_Scopes (Scope (Component_Type (Base)))
+ then
+ -- Generate component invariant checking procedure. This is only
+ -- relevant if the array type is within the scope of the component
+ -- type. Otherwise an array object can only be built using the public
+ -- subprograms for the component type, and calls to those will have
+ -- invariant checks.
Insert_Component_Invariant_Checks
(N, Base, Build_Array_Invariant_Proc (Base, N));
-- our operands using the Minimize_Eliminate circuitry which applies
-- this processing to the two operand subtrees.
- Minimize_Eliminate_Overflow_Checks (Left_Opnd (N), Llo, Lhi);
- Minimize_Eliminate_Overflow_Checks (Right_Opnd (N), Rlo, Rhi);
+ Minimize_Eliminate_Overflow_Checks
+ (Left_Opnd (N), Llo, Lhi, Top_Level => False);
+ Minimize_Eliminate_Overflow_Checks
+ (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
-- See if the range information decides the result of the comparison
-- Entity for Long_Long_Integer'Base (Standard should export this???)
begin
- Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi);
+ Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi, Top_Level => False);
-- If right operand is a subtype name, and the subtype name has no
-- predicate, then we can just replace the right operand with an
-- have not been processed for minimized or eliminated checks.
if Nkind (Rop) = N_Range then
- Minimize_Eliminate_Overflow_Checks (Low_Bound (Rop), Lo, Hi);
- Minimize_Eliminate_Overflow_Checks (High_Bound (Rop), Lo, Hi);
+ Minimize_Eliminate_Overflow_Checks
+ (Low_Bound (Rop), Lo, Hi, Top_Level => False);
+ Minimize_Eliminate_Overflow_Checks
+ (High_Bound (Rop), Lo, Hi, Top_Level => False);
-- We have A in B .. C, treated as A >= B and then A <= C
-- We build a partially initialized aggregate with the
-- values of the discriminants and box initialization
-- for the rest, if other components are present.
+
-- The type of the aggregate is the known subtype of
-- the component. The capture of discriminants must
-- be recursive because subcomponents may be constrained
Next (New_Assoc);
end loop;
- -- If no association, this is not a legal component of
- -- of the type in question, except if its association
- -- is provided with a box.
+ -- If no association, this is not a legal component of the type
+ -- in question, unless its association is provided with a box.
if No (New_Assoc) then
if Box_Present (Parent (Selectr)) then
Plist : List_Id := No_List;
-- List of generated postconditions
+ procedure Check_Access_Invariants (E : Entity_Id);
+ -- If the subprogram returns an access to a type with invariants, or
+ -- has access parameters whose designated type has an invariant, then
+ -- under the same visibility conditions as for other invariant checks,
+ -- the type invariant must be applied to the returned value.
+
function Grab_CC return Node_Id;
-- Prag contains an analyzed contract case pragma. This function copies
-- relevant components of the pragma, creates the corresponding Check
-- that an invariant check is required (for an IN OUT parameter, or
-- the returned value of a function.
+ -----------------------------
+ -- Check_Access_Invariants --
+ -----------------------------
+
+ procedure Check_Access_Invariants (E : Entity_Id) is
+ Call : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Is_Access_Type (Etype (E))
+ and then not Is_Access_Constant (Etype (E))
+ then
+ Typ := Designated_Type (Etype (E));
+
+ if Has_Invariants (Typ)
+ and then Present (Invariant_Procedure (Typ))
+ and then Is_Public_Subprogram_For (Typ)
+ then
+ Obj :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc));
+ Set_Etype (Obj, Typ);
+
+ Call := Make_Invariant_Call (Obj);
+
+ Append_To (Plist,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Make_Null (Loc),
+ Right_Opnd => New_Occurrence_Of (E, Loc)),
+ Then_Statements => New_List (Call)));
+ end if;
+ end if;
+ end Check_Access_Invariants;
+
-------------
-- Grab_CC --
-------------
Formal : Entity_Id;
begin
- -- Check function return result
+ -- Check function return result. If result is an access type there
+ -- may be invariants on the designated type.
if Ekind (Designator) /= E_Procedure
and then Has_Invariants (Etype (Designator))
then
return True;
+
+ elsif Ekind (Designator) /= E_Procedure
+ and then Is_Access_Type (Etype (Designator))
+ and then Has_Invariants (Designated_Type (Etype (Designator)))
+ then
+ return True;
end if;
-- Check parameters
Formal := First_Formal (Designator);
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter
- and then
- (Has_Invariants (Etype (Formal))
- or else Present (Predicate_Function (Etype (Formal))))
+ and then (Has_Invariants (Etype (Formal))
+ or else Present (Predicate_Function (Etype (Formal))))
+ then
+ return True;
+
+ elsif Is_Access_Type (Etype (Formal))
+ and then Has_Invariants (Designated_Type (Etype (Formal)))
then
return True;
end if;
Append_To (Plist,
Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
end if;
+
+ -- Same if return value is an access to type with invariants.
+
+ Check_Access_Invariants (Rent);
end;
-- Procedure rather than a function
begin
Formal := First_Formal (Designator);
while Present (Formal) loop
- if Ekind (Formal) /= E_In_Parameter then
+ if Ekind (Formal) /= E_In_Parameter
+ or else Is_Access_Type (Etype (Formal))
+ then
Ftype := Etype (Formal);
if Has_Invariants (Ftype)
(New_Occurrence_Of (Formal, Loc)));
end if;
+ Check_Access_Invariants (Formal);
+
if Present (Predicate_Function (Ftype)) then
Append_To (Plist,
Make_Predicate_Check
Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
begin
+ -- Ignore if not Ada 2012 or beyond
+
if Ada_Version < Ada_2012 then
return;
- end if;
- -- Copy the dimension of 'From to 'To'
+ -- For Ada 2012, Copy the dimension of 'From to 'To'
- if Exists (Dims_Of_From) then
+ elsif Exists (Dims_Of_From) then
Set_Dimensions (To, Dims_Of_From);
end if;
end Copy_Dimensions;
-- Look for a symbols parameter association in the list of actuals
while Present (Actual) loop
+
-- Positional parameter association case when the actual is a
-- string literal.
if Nkind (Actual) = N_String_Literal then
Actual_Str := Actual;
- -- Named parameter association case when the selector name is
- -- Symbol.
+ -- Named parameter association case when selector name is Symbol
elsif Nkind (Actual) = N_Parameter_Association
and then Chars (Selector_Name (Actual)) = Name_Symbol
end if;
if Present (Actual_Str) then
+
-- Return True if the actual comes from source or if the string
-- of symbols doesn't have the default value (i.e. it is "").
return
Is_RTU (E, System_Dim_Float_IO)
- or Is_RTU (E, System_Dim_Integer_IO);
+ or else
+ Is_RTU (E, System_Dim_Integer_IO);
end Is_Dim_IO_Package_Entity;
-------------------------------------
-- literal default value in the list of formals Formals.
procedure Copy_Dimensions (From, To : Node_Id);
- -- Copy dimension vector of From to To.
+ -- Copy dimension vector of From to To
+ -- We should say what the requirements on From and To are here ???
procedure Eval_Op_Expon_For_Dimensioned_Type
(N : Node_Id;
Loc : constant Source_Ptr := Sloc (N);
Pred : constant List_Id := Static_Predicate (Typ);
Test : Node_Id;
+
begin
if No (Pred) then
return True;
function Eval_Static_Predicate_Check
(N : Node_Id;
Typ : Entity_Id) return Boolean;
- -- Evaluate a static predicate check applied to a scalar literal.
+ -- Evaluate a static predicate check applied to a scalar literal
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
projects / gcc.git / commitdiff