From c7e152b57d8f22c33077340f5684d8098062bdff Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Oct 2012 10:04:47 +0200 Subject: [PATCH] [multiple changes] 2012-10-02 Robert Dewar * sem_dim.adb: Minor code reorganization. * sem_dim.ads: Add comment. 2012-10-02 Robert Dewar * 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 * 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 --- gcc/ada/ChangeLog | 21 +++++++++++++ gcc/ada/checks.adb | 75 +++++++++++++++++++++++++++++++++----------- gcc/ada/checks.ads | 17 ++++++++-- gcc/ada/exp_ch3.adb | 51 +++++++++++++++++++++++++----- gcc/ada/exp_ch4.adb | 14 ++++++--- gcc/ada/sem_aggr.adb | 6 ++-- gcc/ada/sem_ch6.adb | 72 +++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_dim.adb | 15 +++++---- gcc/ada/sem_dim.ads | 3 +- gcc/ada/sem_eval.adb | 1 + gcc/ada/sem_eval.ads | 2 +- 11 files changed, 228 insertions(+), 49 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 145db865c3e..3b8405c07c4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2012-10-02 Robert Dewar + + * sem_dim.adb: Minor code reorganization. + * sem_dim.ads: Add comment. + +2012-10-02 Robert Dewar + + * 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 + + * 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 * sem_aggr.adb (New_Copy_Tree_And_Copy_Dimensions): New routine. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 12c2b6a2805..5923c83c0a4 100644 --- a/gcc/ada/checks.adb +++ b/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; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 9fd8034b777..583d558e7df 100644 --- a/gcc/ada/checks.ads +++ b/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 -- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d7427d9d523..af5dadd9abc 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index dcf33824cfa..79476fffc25 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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 diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index dc03b66002d..e73b8758386 100644 --- a/gcc/ada/sem_aggr.adb +++ b/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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4144fe04922..6d825987c59 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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 diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index e25c1589881..15b32dca7fc 100644 --- a/gcc/ada/sem_dim.adb +++ b/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; ------------------------------------- diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index e7dc3ae2917..d069df94486 100644 --- a/gcc/ada/sem_dim.ads +++ b/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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 933211a2d32..f18dc00c655 100644 --- a/gcc/ada/sem_eval.adb +++ b/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; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 787e6d346c8..b2f5aa22ca1 100644 --- a/gcc/ada/sem_eval.ads +++ b/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 -- 2.30.2