From 1955e2bd151592049b8da3197102084db720e8fa Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 6 Jan 2015 09:07:29 +0000 Subject: [PATCH] 2015-01-06 Arnaud Charlet * a-reatim.adb ("/"): Add explicit pragma Unsuppress (Division_Check). 2015-01-06 Robert Dewar * sem_prag.adb (Process_Suppress_Unsuppress): Add extra warning for ignoring pragma Suppress (Elaboration_Check) in SPARK mode. 2015-01-06 Javier Miranda * 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). git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219227 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 16 ++++++++++++++++ gcc/ada/a-reatim.adb | 4 +++- gcc/ada/exp_disp.adb | 24 +++++++++++++++++++----- gcc/ada/sem_prag.adb | 4 +++- 4 files changed, 41 insertions(+), 7 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a8f36b90dec1..64c02b3b572f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2015-01-06 Arnaud Charlet + + * a-reatim.adb ("/"): Add explicit pragma Unsuppress (Division_Check). + +2015-01-06 Robert Dewar + + * sem_prag.adb (Process_Suppress_Unsuppress): Add extra warning + for ignoring pragma Suppress (Elaboration_Check) in SPARK mode. + +2015-01-06 Javier Miranda + + * 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 * prj-env.adb: Minor comment update. diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index ef0632bc5bc1..f59d083b03c1 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -114,12 +114,14 @@ package body Ada.Real_Time is function "/" (Left, Right : Time_Span) return Integer is pragma Unsuppress (Overflow_Check); + pragma Unsuppress (Division_Check); begin return Integer (Duration (Left) / Duration (Right)); end "/"; function "/" (Left : Time_Span; Right : Integer) return Time_Span is pragma Unsuppress (Overflow_Check); + pragma Unsuppress (Division_Check); begin return Time_Span (Duration (Left) / Right); end "/"; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 99105e0ea4f1..302f7210b13a 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1138,6 +1138,25 @@ package body Exp_Disp is Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); 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 declare @@ -1177,11 +1196,6 @@ package body Exp_Disp is Prefix => New_Occurrence_Of (Iface_Typ, Loc), Attribute_Name => Name_Tag)))); end if; - - -- Just do a conversion ??? - - Rewrite (N, Unchecked_Convert_To (Etype (N), N)); - Analyze (N); end if; return; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 58acefdd7a79..207f4ba20eb5 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9050,7 +9050,9 @@ package body Sem_Prag is if C = Elaboration_Check and then SPARK_Mode = On then 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; -- One-argument case -- 2.11.4.GIT