[multiple changes]
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> * 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 <kirtchev@adacore.com> * exp_unst.adb: Minor reformatting. 2015-10-26 Ed Schonberg <schonberg@adacore.com> * sem_ch6.adb: Improve error msg. From-SVN: r229341
This commit is contained in:
Arnaud Charlet
parent
ec6cfc5dc2
commit
356ffab8a2
|
|
@ -1,3 +1,18 @@
|
|||
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* 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 <kirtchev@adacore.com>
|
||||
|
||||
* exp_unst.adb: Minor reformatting.
|
||||
|
||||
2015-10-26 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch6.adb: Improve error msg.
|
||||
|
||||
2015-10-26 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_disp.adb (Check_Controlling_Type): Handle properly the
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue