Commit 91afcbfd by Arnaud Charlet

[multiple changes]

2015-01-06  Arnaud Charlet  <charlet@adacore.com>

	* a-reatim.adb ("/"): Add explicit pragma Unsuppress (Division_Check).

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Process_Suppress_Unsuppress): Add extra warning
	for ignoring pragma Suppress (Elaboration_Check) in SPARK mode.

2015-01-06  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Expand_Interface_Conversion): No displacement
	of the pointer to the object needed when the type of the operand
	is not an interface type and the interface is one of its parent
	types (since they share the primary dispatch table).

From-SVN: r219227
parent 966fc9c5
2015-01-06 Arnaud Charlet <charlet@adacore.com>
* a-reatim.adb ("/"): Add explicit pragma Unsuppress (Division_Check).
2015-01-06 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Process_Suppress_Unsuppress): Add extra warning
for ignoring pragma Suppress (Elaboration_Check) in SPARK mode.
2015-01-06 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Expand_Interface_Conversion): No displacement
of the pointer to the object needed when the type of the operand
is not an interface type and the interface is one of its parent
types (since they share the primary dispatch table).
2015-01-06 Vincent Celier <celier@adacore.com> 2015-01-06 Vincent Celier <celier@adacore.com>
* prj-env.adb: Minor comment update. * prj-env.adb: Minor comment update.
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, AdaCore -- -- Copyright (C) 1995-2014, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -114,12 +114,14 @@ package body Ada.Real_Time is ...@@ -114,12 +114,14 @@ package body Ada.Real_Time is
function "/" (Left, Right : Time_Span) return Integer is function "/" (Left, Right : Time_Span) return Integer is
pragma Unsuppress (Overflow_Check); pragma Unsuppress (Overflow_Check);
pragma Unsuppress (Division_Check);
begin begin
return Integer (Duration (Left) / Duration (Right)); return Integer (Duration (Left) / Duration (Right));
end "/"; end "/";
function "/" (Left : Time_Span; Right : Integer) return Time_Span is function "/" (Left : Time_Span; Right : Integer) return Time_Span is
pragma Unsuppress (Overflow_Check); pragma Unsuppress (Overflow_Check);
pragma Unsuppress (Division_Check);
begin begin
return Time_Span (Duration (Left) / Right); return Time_Span (Duration (Left) / Right);
end "/"; end "/";
......
...@@ -1138,6 +1138,25 @@ package body Exp_Disp is ...@@ -1138,6 +1138,25 @@ package body Exp_Disp is
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if; end if;
-- No displacement of the pointer to the object needed when the type of
-- the operand is not an interface type and the interface is one of
-- its parent types (since they share the primary dispatch table).
declare
Opnd : Entity_Id := Operand_Typ;
begin
if Is_Access_Type (Opnd) then
Opnd := Designated_Type (Opnd);
end if;
if not Is_Interface (Opnd)
and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
then
return;
end if;
end;
-- Evaluate if we can statically displace the pointer to the object -- Evaluate if we can statically displace the pointer to the object
declare declare
...@@ -1177,11 +1196,6 @@ package body Exp_Disp is ...@@ -1177,11 +1196,6 @@ package body Exp_Disp is
Prefix => New_Occurrence_Of (Iface_Typ, Loc), Prefix => New_Occurrence_Of (Iface_Typ, Loc),
Attribute_Name => Name_Tag)))); Attribute_Name => Name_Tag))));
end if; end if;
-- Just do a conversion ???
Rewrite (N, Unchecked_Convert_To (Etype (N), N));
Analyze (N);
end if; end if;
return; return;
......
...@@ -9050,7 +9050,9 @@ package body Sem_Prag is ...@@ -9050,7 +9050,9 @@ package body Sem_Prag is
if C = Elaboration_Check and then SPARK_Mode = On then if C = Elaboration_Check and then SPARK_Mode = On then
Error_Pragma_Arg Error_Pragma_Arg
("Suppress of Elaboration_Check ignored in SPARK??", Arg1); ("Suppress of Elaboration_Check ignored in SPARK??",
"\elaboration checking rules are statically enforced "
& "(SPARK RM 7.7)", Arg1);
end if; end if;
-- One-argument case -- One-argument case
......
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