From: Arnaud Charlet Date: Mon, 26 Oct 2015 11:38:57 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=356ffab8a2f26638a14d77c2e926fee9c4a67ad1;p=gcc.git [multiple changes] 2015-10-26 Hristian Kirtchev * exp_ch4.adb (Is_OK_Object_Reference): New routine. (Substitute_Valid_Check): Perform the 'Valid subsitution but do not suggest the use of the attribute if the left hand operand does not denote an object as it leads to illegal code. 2015-10-26 Hristian Kirtchev * exp_unst.adb: Minor reformatting. 2015-10-26 Ed Schonberg * sem_ch6.adb: Improve error msg. From-SVN: r229341 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4c3620f9ced..244014f20c8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2015-10-26 Hristian Kirtchev + + * exp_ch4.adb (Is_OK_Object_Reference): New routine. + (Substitute_Valid_Check): Perform the 'Valid subsitution but do + not suggest the use of the attribute if the left hand operand + does not denote an object as it leads to illegal code. + +2015-10-26 Hristian Kirtchev + + * exp_unst.adb: Minor reformatting. + +2015-10-26 Ed Schonberg + + * sem_ch6.adb: Improve error msg. + 2015-10-26 Ed Schonberg * sem_disp.adb (Check_Controlling_Type): Handle properly the diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 6714894f637..0b1fe7920a0 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5493,9 +5493,6 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); - Ltyp : Entity_Id; - Rtyp : Entity_Id; - procedure Substitute_Valid_Check; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. @@ -5505,6 +5502,49 @@ package body Exp_Ch4 is ---------------------------- procedure Substitute_Valid_Check is + function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; + -- Determine whether arbitrary node Nod denotes a source object that + -- may safely act as prefix of attribute 'Valid. + + ---------------------------- + -- Is_OK_Object_Reference -- + ---------------------------- + + function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is + Obj_Ref : Node_Id; + + begin + -- Inspect the original operand + + Obj_Ref := Original_Node (Nod); + + -- The object reference must be a source construct, otherwise the + -- codefix suggestion may refer to nonexistent code from a user + -- perspective. + + if Comes_From_Source (Obj_Ref) then + + -- Recover the actual object reference. There may be more cases + -- to consider??? + + loop + if Nkind_In (Obj_Ref, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Obj_Ref := Expression (Obj_Ref); + else + exit; + end if; + end loop; + + return Is_Object_Reference (Obj_Ref); + end if; + + return False; + end Is_OK_Object_Reference; + + -- Start of processing for Substitute_Valid_Check + begin Rewrite (N, Make_Attribute_Reference (Loc, @@ -5513,20 +5553,27 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Restyp); - -- Give warning unless overflow checking is MINIMIZED or ELIMINATED, - -- in which case, this usage makes sense, and in any case, we have - -- actually eliminated the danger of optimization above. + -- Emit a warning when the left-hand operand of the membership test + -- is a source object, otherwise the use of attribute 'Valid would be + -- illegal. The warning is not given when overflow checking is either + -- MINIMIZED or ELIMINATED, as the danger of optimization has been + -- eliminated above. - if Overflow_Check_Mode not in Minimized_Or_Eliminated then + if Is_OK_Object_Reference (Lop) + and then Overflow_Check_Mode not in Minimized_Or_Eliminated + then Error_Msg_N ("??explicit membership test may be optimized away", N); Error_Msg_N -- CODEFIX ("\??use ''Valid attribute instead", N); end if; - - return; end Substitute_Valid_Check; + -- Local variables + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + -- Start of processing for Expand_N_In begin @@ -9767,7 +9814,7 @@ package body Exp_Ch4 is if not Is_Discrete_Type (Etype (N)) then null; - -- Don't do this on the left hand of an assignment statement. + -- Don't do this on the left-hand side of an assignment statement. -- Normally one would think that references like this would not -- occur, but they do in generated code, and mean that we really -- do want to assign the discriminant. @@ -10212,7 +10259,7 @@ package body Exp_Ch4 is Cons := No_List; -- If type is unconstrained we have to add a constraint, copied - -- from the actual value of the left hand side. + -- from the actual value of the left-hand side. if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 0b738d1b450..5db40e52a8d 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -316,12 +316,12 @@ package body Exp_Unst is Callee : Entity_Id; procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean); - -- Given a type T, checks if it is a static type defined as a - -- type with no dynamic bounds in sight. If so, the only action - -- is to set Is_Static_Type True for T. If T is not a static - -- type, then all types with dynamic bounds associated with - -- T are detected, and their bounds are marked as uplevel - -- referenced if not at the library level, and DT is set True. + -- Given a type T, checks if it is a static type defined as a type + -- with no dynamic bounds in sight. If so, the only action is to + -- set Is_Static_Type True for T. If T is not a static type, then + -- all types with dynamic bounds associated with T are detected, + -- and their bounds are marked as uplevel referenced if not at the + -- library level, and DT is set True. procedure Note_Uplevel_Ref (E : Entity_Id; @@ -407,7 +407,7 @@ package body Exp_Unst is end if; end; - -- For record type, check all components + -- For record type, check all components elsif Is_Record_Type (T) then declare @@ -420,7 +420,7 @@ package body Exp_Unst is end loop; end; - -- For array type, check index types and component type + -- For array type, check index types and component type elsif Is_Array_Type (T) then declare @@ -467,9 +467,9 @@ package body Exp_Unst is if Caller = Callee then return; - -- Callee may be a function that returns an array, and - -- that has been rewritten as a procedure. If caller is - -- that procedure, nothing to do either. + -- Callee may be a function that returns an array, and that has + -- been rewritten as a procedure. If caller is that procedure, + -- nothing to do either. elsif Ekind (Callee) = E_Function and then Rewritten_For_C (Callee) @@ -1183,8 +1183,9 @@ package body Exp_Unst is -- Now we can insert the AREC declarations into the body - -- type ARECnT is record .. end record; - -- pragma Suppress_Initialization (ARECnT); + -- type ARECnT is record .. end record; + -- pragma Suppress_Initialization (ARECnT); + -- Note that we need to set the Suppress_Initialization -- flag after Decl_ARECnT has been analyzed. @@ -1438,8 +1439,8 @@ package body Exp_Unst is -- probably happens as a result of not properly treating -- instance bodies. To be examined ??? - -- If this test is omitted, then the compilation of - -- freeze.adb and inline.adb fail in unnesting mode. + -- If this test is omitted, then the compilation of freeze.adb + -- and inline.adb fail in unnesting mode. if No (STJR.ARECnF) then goto Continue; @@ -1451,12 +1452,11 @@ package body Exp_Unst is Push_Scope (STJR.Ent); - -- Now we need to rewrite the reference. We have a - -- reference is from level STJR.Lev to level STJE.Lev. - -- The general form of the rewritten reference for - -- entity X is: + -- Now we need to rewrite the reference. We have a reference + -- from level STJR.Lev to level STJE.Lev. The general form of + -- the rewritten reference for entity X is: - -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) + -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) -- where a,b,c,d .. m = -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev @@ -1562,11 +1562,10 @@ package body Exp_Unst is begin if Present (STT.ARECnF) then - -- CTJ.N is a call to a subprogram which may require - -- a pointer to an activation record. The subprogram - -- containing the call is CTJ.From and the subprogram being - -- called is CTJ.To, so we have a call from level STF.Lev to - -- level STT.Lev. + -- CTJ.N is a call to a subprogram which may require a pointer + -- to an activation record. The subprogram containing the call + -- is CTJ.From and the subprogram being called is CTJ.To, so we + -- have a call from level STF.Lev to level STT.Lev. -- There are three possibilities: @@ -1576,10 +1575,10 @@ package body Exp_Unst is if STF.Lev = STT.Lev then Extra := New_Occurrence_Of (STF.ARECnF, Loc); - -- For a call that goes down a level, we pass a pointer - -- to the activation record constructed within the caller - -- (which may be the outer level subprogram, but also may - -- be a more deeply nested caller). + -- For a call that goes down a level, we pass a pointer to the + -- activation record constructed within the caller (which may + -- be the outer-level subprogram, but also may be a more deeply + -- nested caller). elsif STT.Lev = STF.Lev + 1 then Extra := New_Occurrence_Of (STF.ARECnP, Loc); @@ -1601,9 +1600,9 @@ package body Exp_Unst is pragma Assert (STT.Lev < STF.Lev); Extra := New_Occurrence_Of (STF.ARECnF, Loc); - SubX := Subp_Index (CTJ.Caller); + SubX := Subp_Index (CTJ.Caller); for K in reverse STT.Lev .. STF.Lev - 1 loop - SubX := Enclosing_Subp (SubX); + SubX := Enclosing_Subp (SubX); Extra := Make_Selected_Component (Loc, Prefix => Extra, @@ -1628,8 +1627,8 @@ package body Exp_Unst is Append (ExtraP, Parameter_Associations (CTJ.N)); - -- We need to deal with the actual parameter chain as well. - -- The newly added parameter is always the last actual. + -- We need to deal with the actual parameter chain as well. The + -- newly added parameter is always the last actual. Act := First_Named_Actual (CTJ.N); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ec92bf45813..d36cf850b4b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -674,7 +674,7 @@ package body Sem_Ch6 is Scope_Depth (Scope (Scope_Id)) then Error_Msg_N - ("access discriminant in return aggregate will be " + ("access discriminant in return aggregate would be " & "a dangling reference", Obj); end if; end if;