Skip to content

R
riscv-gcc-1
Commit c7e152b5 by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r191956
parent 0c609a21
Showing with 228 additions and 49 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/checks.adb
......@@ -1113,8 +1113,11 @@ package body Checks is
-- 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
......@@ -2333,23 +2336,24 @@ package body Checks is
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;
......@@ -6549,9 +6553,10 @@ package body Checks is
----------------------------------------
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)));
......@@ -6578,6 +6583,11 @@ package body Checks is
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);
......@@ -6609,7 +6619,7 @@ package body Checks is
-- 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
......@@ -6638,10 +6648,12 @@ package body Checks is
-- 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;
......@@ -6650,10 +6662,13 @@ package body Checks is
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
......@@ -7007,14 +7022,33 @@ package body Checks is
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);
......@@ -7079,6 +7113,11 @@ package body Checks is
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;
......
gcc/ada/checks.ads
......@@ -260,9 +260,10 @@ package Checks is
-- 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
......@@ -321,6 +322,16 @@ package Checks is
--
-- 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 --
......
gcc/ada/exp_ch3.adb
......@@ -3674,20 +3674,43 @@ package body Exp_Ch3 is
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;
----------------------------
......@@ -3706,7 +3729,16 @@ package body Exp_Ch3 is
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;
......@@ -5861,9 +5893,14 @@ package body Exp_Ch3 is
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));
......
gcc/ada/exp_ch4.adb
......@@ -2345,8 +2345,10 @@ package body Exp_Ch4 is
-- 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
......@@ -3735,7 +3737,7 @@ package body Exp_Ch4 is
-- 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
......@@ -3760,8 +3762,10 @@ package body Exp_Ch4 is
-- 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
......
gcc/ada/sem_aggr.adb
......@@ -4080,6 +4080,7 @@ package body Sem_Aggr is
-- 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
......@@ -4434,9 +4435,8 @@ package body Sem_Aggr is
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
......
gcc/ada/sem_ch6.adb
......@@ -11078,6 +11078,12 @@ package body Sem_Ch6 is
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
......@@ -11108,6 +11114,43 @@ package body Sem_Ch6 is
-- 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 --
-------------
......@@ -11308,12 +11351,19 @@ package body Sem_Ch6 is
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
......@@ -11321,9 +11371,13 @@ package body Sem_Ch6 is
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;
......@@ -11731,6 +11785,10 @@ package body Sem_Ch6 is
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
......@@ -11750,7 +11808,9 @@ package body Sem_Ch6 is
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)
......@@ -11762,6 +11822,8 @@ package body Sem_Ch6 is
(New_Occurrence_Of (Formal, Loc)));
end if;
Check_Access_Invariants (Formal);
if Present (Predicate_Function (Ftype)) then
Append_To (Plist,
Make_Predicate_Check
......
gcc/ada/sem_dim.adb
......@@ -2206,13 +2206,14 @@ package body Sem_Dim is
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;
......@@ -2730,14 +2731,14 @@ package body Sem_Dim is
-- 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
......@@ -2751,6 +2752,7 @@ package body Sem_Dim is
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 "").
......@@ -3206,7 +3208,8 @@ package body Sem_Dim 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;
-------------------------------------
......
gcc/ada/sem_dim.ads
......@@ -163,7 +163,8 @@ package Sem_Dim is
-- 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;
......
gcc/ada/sem_eval.adb
......@@ -3260,6 +3260,7 @@ package body Sem_Eval is
Loc : constant Source_Ptr := Sloc (N);
Pred : constant List_Id := Static_Predicate (Typ);
Test : Node_Id;
begin
if No (Pred) then
return True;
......
gcc/ada/sem_eval.ads
......@@ -320,7 +320,7 @@ package Sem_Eval is
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
......
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