aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gcc/ada/ChangeLog58
-rw-r--r--gcc/ada/a-cborse.adb87
-rw-r--r--gcc/ada/a-cborse.ads26
-rw-r--r--gcc/ada/a-chtgop.adb47
-rw-r--r--gcc/ada/a-chtgop.ads12
-rw-r--r--gcc/ada/a-cihase.adb91
-rw-r--r--gcc/ada/a-cihase.ads27
-rw-r--r--gcc/ada/a-cohase.adb55
-rw-r--r--gcc/ada/a-elchha.adb9
-rw-r--r--gcc/ada/a-except-2005.adb50
-rw-r--r--gcc/ada/a-except.adb62
-rw-r--r--gcc/ada/a-exexda.adb111
-rw-r--r--gcc/ada/a-exextr.adb4
-rw-r--r--gcc/ada/a-exstat.adb8
-rw-r--r--gcc/ada/checks.adb448
-rw-r--r--gcc/ada/checks.ads13
-rw-r--r--gcc/ada/exp_aggr.adb3
-rw-r--r--gcc/ada/exp_util.adb12
-rw-r--r--gcc/ada/s-tassta.adb8
19 files changed, 897 insertions, 234 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5c4a30b..8db9279 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,61 @@
+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New
+ subprogram, used by all versions of hashed sets, to delete a node
+ whose element has been improperly updated through a Reference_
+ Preserving key.
+ * a-cohase.adb: Remove Delete_Node, use new common procedure
+ Delete_Node_At_Index.
+ * a-cihase.ads: Add Reference_Control_Type to package Generic_Keys.
+ * a-cihase.adb: Add Adjust and Finalize routines for
+ Reference_Control_Type.
+ (Reference_Preserving_Key): Build aggregate for
+ Reference_Control_Type
+
+2014-07-30 Yannick Moy <moy@adacore.com>
+
+ * checks.adb, checks.ads (Determine_Range_R): New procedure to
+ determine the possible range of a floating-point expression.
+
+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cborse.ads: Add Reference_Control_Type to package Generic_Keys.
+ * a-cborse.adb: Add Adjust and Finalize routines for
+ Reference_Control_Type.
+ (Reference_Preserving_Key): Build aggregate for
+ Reference_Control_Type.
+ (Delete): Check for tampering, and raise Program_Error (not
+ Constraint_Error) when attempting to delete an element not in
+ the set.
+ (Insert): Ditto.
+
+2014-07-30 Bob Duff <duff@adacore.com>
+
+ * a-elchha.adb, a-except-2005.adb, a-except.adb, a-exexda.adb,
+ * a-exextr.adb, a-exstat.adb, exp_intr.ads, s-tassta.adb:
+ Exception_Information is used to produce useful debugging
+ information for the programmer. However, it was also used to
+ implement the stream attributes for type Exception_Occurrence. The
+ latter requires a stable and portable interface, which meant
+ that we couldn't include a symbolic traceback. A separate set of
+ routines was used to provide symbolic tracebacks under program
+ control (i.e. not automatically). The goal of this ticket is
+ to provide such automatic tracebacks, so the change here is to
+ split the two functionalities: Exception_Information gives the
+ maximally useful information for debugging (i.e. it now includes
+ a symbolic traceback when a decorator is set, and it can be
+ improved freely in the future without disturbing streaming).
+ Untailored_Exception_Information always uses hexadecimal addresses
+ in the traceback, has a stable and portable output, and is now
+ used for streaming.
+
+2014-07-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_aggr.adb (Expand_Array_Aggregate): Add missing test
+ on the target of the assignment to find out whether it
+ can be directly done by the back-end.
+ * exp_util.adb (Is_Possibly_Unaligned_Slice): Remove obscure test.
+
2014-07-30 Robert Dewar <dewar@adacore.com>
* inline.adb, a-coorse.adb, a-coorse.ads, a-cohase.adb, a-cohase.ads,
diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb
index ea6a6d0..db9c8c6 100644
--- a/gcc/ada/a-cborse.adb
+++ b/gcc/ada/a-cborse.adb
@@ -482,6 +482,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is
raise Program_Error with "Position cursor designates wrong set";
end if;
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is busy)";
+ end if;
+
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Delete");
@@ -496,7 +501,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
begin
if X = 0 then
- raise Constraint_Error with "attempt to delete element not in set";
+ raise Program_Error with "attempt to delete element not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container, X);
@@ -734,6 +739,23 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ B : Natural renames Control.Container.Busy;
+ L : Natural renames Control.Container.Lock;
+ begin
+ B := B + 1;
+ L := L + 1;
+ end;
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -842,6 +864,30 @@ package body Ada.Containers.Bounded_Ordered_Sets is
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ B : Natural renames Control.Container.Busy;
+ L : Natural renames Control.Container.Lock;
+ begin
+ B := B - 1;
+ L := L - 1;
+ end;
+
+ if not (Key (Control.Pos) = Control.Old_Key.all) then
+ Delete (Control.Container.all, Key (Control.Pos));
+ raise Program_Error;
+ end if;
+
+ Control.Container := null;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
@@ -939,15 +985,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is
(Vet (Container, Position.Node),
"bad cursor in function Reference_Preserving_Key");
- -- Some form of finalization will be required in order to actually
- -- check that the key-part of the element designated by Position has
- -- not changed. ???
-
declare
N : Node_Type renames Container.Nodes (Position.Node);
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
- return (Element => N.Element'Access);
+ return R : constant Reference_Type :=
+ (Element => N.Element'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Pos => Position,
+ Old_Key => new Key_Type'(Key (Position))))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
end;
+
end Reference_Preserving_Key;
function Reference_Preserving_Key
@@ -963,8 +1018,21 @@ package body Ada.Containers.Bounded_Ordered_Sets is
declare
N : Node_Type renames Container.Nodes (Node);
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
begin
- return (Element => N.Element'Access);
+ return R : constant Reference_Type :=
+ (Element => N.Element'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Pos => Find (Container, Key),
+ Old_Key => new Key_Type'(Key)))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+
end;
end Reference_Preserving_Key;
@@ -1181,6 +1249,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is
-- Start of processing for Insert_Sans_Hint
begin
+ if Container.Busy > 0 then
+ raise Program_Error with
+ "attemot to tamper with cursors (set is busy)";
+ end if;
+
Conditional_Insert_Sans_Hint
(Container,
New_Item,
diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads
index 03fdd49..aee0bf9 100644
--- a/gcc/ada/a-cborse.ads
+++ b/gcc/ada/a-cborse.ads
@@ -277,11 +277,33 @@ package Ada.Containers.Bounded_Ordered_Sets is
Key : Key_Type) return Reference_Type;
private
- type Reference_Type (Element : not null access Element_Type) is
- null record;
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Key_Access is access all Key_Type;
use Ada.Streams;
+ type Reference_Control_Type is
+ new Ada.Finalization.Controlled with
+ record
+ Container : Set_Access;
+ Pos : Cursor;
+ Old_Key : Key_Access;
+ end record;
+
+ overriding procedure
+ Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
+ overriding procedure
+ Finalize (Control : in out Reference_Control_Type);
+ pragma Inline (Finalize);
+
+ type Reference_Type (Element : not null access Element_Type) is record
+ Control : Reference_Control_Type;
+ end record;
+
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Reference_Type);
diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb
index 4227c8f..2b3fbd3 100644
--- a/gcc/ada/a-chtgop.adb
+++ b/gcc/ada/a-chtgop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -195,6 +195,51 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
end loop;
end Clear;
+ --------------------------
+ -- Delete_Node_At_Index --
+ --------------------------
+
+ procedure Delete_Node_At_Index
+ (HT : in out Hash_Table_Type;
+ Indx : Hash_Type;
+ X : in out Node_Access)
+ is
+ Prev : Node_Access;
+ Curr : Node_Access;
+
+ begin
+ Prev := HT.Buckets (Indx);
+ if Prev = X then
+ HT.Buckets (Indx) := Next (Prev);
+ HT.Length := HT.Length - 1;
+ Free (X);
+ return;
+ end if;
+
+ if HT.Length = 1 then
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
+ end if;
+
+ loop
+ Curr := Next (Prev);
+
+ if Curr = null then
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
+ end if;
+
+ if Curr = X then
+ Set_Next (Node => Prev, Next => Next (Curr));
+ HT.Length := HT.Length - 1;
+ Free (X);
+ return;
+ end if;
+ Prev := Curr;
+ end loop;
+
+ end Delete_Node_At_Index
+;
---------------------------
-- Delete_Node_Sans_Free --
---------------------------
diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads
index c8e22c3..994f520 100644
--- a/gcc/ada/a-chtgop.ads
+++ b/gcc/ada/a-chtgop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -128,6 +128,16 @@ package Ada.Containers.Hash_Tables.Generic_Operations is
-- rehashed onto the new buckets array, and the old buckets array is
-- deallocated. Program_Error is raised if the hash table is busy.
+ procedure Delete_Node_At_Index
+ (HT : in out Hash_Table_Type;
+ Indx : Hash_Type;
+ X : in out Node_Access);
+
+ -- Delete a node whose bucket position is known. Used to remove a node
+ -- whose element has been modified through a key_preserving reference.
+ -- We cannot use the value of the element precisely because the current
+ -- value does not correspond to the hash code that determines the bucket.
+
procedure Delete_Node_Sans_Free
(HT : in out Hash_Table_Type;
X : Node_Access);
diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb
index 87c4ac4..44d3dc1 100644
--- a/gcc/ada/a-cihase.adb
+++ b/gcc/ada/a-cihase.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -2139,6 +2139,24 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Hash => Hash,
Equivalent_Keys => Equivalent_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ HT : Hash_Table_Type renames Control.Container.HT;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+ begin
+ B := B + 1;
+ L := L + 1;
+ end;
+ end if;
+ end Adjust;
+
------------------------
-- Constant_Reference --
------------------------
@@ -2249,6 +2267,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Free (X);
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ HT : Hash_Table_Type renames Control.Container.HT;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+ begin
+ B := B - 1;
+ L := L - 1;
+ end;
+
+ if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
+ HT_Ops.Delete_Node_At_Index
+ (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
+ raise Program_Error;
+ end if;
+
+ Control.Container := null;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
@@ -2322,11 +2366,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Vet (Position),
"bad cursor in function Reference_Preserving_Key");
- -- Some form of finalization will be required in order to actually
- -- check that the key-part of the element designated by Position has
- -- not changed. ???
+ declare
+ HT : Hash_Table_Type renames Container.HT;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- return (Element => Position.Node.Element.all'Access);
+ begin
+ return R : constant Reference_Type :=
+ (Element => Position.Node.Element.all'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Index => HT_Ops.Index (HT, Position.Node),
+ Old_Pos => Position,
+ Old_Hash => Hash (Key (Position))))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
end Reference_Preserving_Key;
function Reference_Preserving_Key
@@ -2345,11 +2403,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise Program_Error with "Node has no element";
end if;
- -- Some form of finalization will be required in order to actually
- -- check that the key-part of the element designated by Key has not
- -- changed. ???
+ declare
+ HT : Hash_Table_Type renames Container.HT;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+ P : constant Cursor := Find (Container, Key);
- return (Element => Node.Element.all'Access);
+ begin
+ return R : constant Reference_Type :=
+ (Element => Node.Element.all'Access,
+ Control =>
+ (Controlled with
+ Container => Container'Access,
+ Index => HT_Ops.Index (HT, P.Node),
+ Old_Pos => P,
+ Old_Hash => Hash (Key)))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
end Reference_Preserving_Key;
-------------
diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads
index 2c4dec5..86eb4d0 100644
--- a/gcc/ada/a-cihase.ads
+++ b/gcc/ada/a-cihase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -430,8 +430,29 @@ package Ada.Containers.Indefinite_Hashed_Sets is
Key : Key_Type) return Reference_Type;
private
- type Reference_Type (Element : not null access Element_Type)
- is null record;
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Reference_Control_Type is
+ new Ada.Finalization.Controlled with
+ record
+ Container : Set_Access;
+ Index : Hash_Type;
+ Old_Pos : Cursor;
+ Old_Hash : Hash_Type;
+ end record;
+
+ overriding procedure
+ Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
+ overriding procedure
+ Finalize (Control : in out Reference_Control_Type);
+ pragma Inline (Finalize);
+
+ type Reference_Type (Element : not null access Element_Type) is record
+ Control : Reference_Control_Type;
+ end record;
use Ada.Streams;
diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb
index b0c16df..841cec2 100644
--- a/gcc/ada/a-cohase.adb
+++ b/gcc/ada/a-cohase.adb
@@ -132,15 +132,6 @@ package body Ada.Containers.Hashed_Sets is
procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node);
- procedure Delete_Node
- (C : in out Set;
- Indx : Hash_Type;
- X : in out Node_Access);
- -- Delete a node whose bucket position is known. Used to remove a node
- -- whose element has been modified through a key_preserving reference.
- -- We cannot use the value of the element precisely because the current
- -- value does not correspond to the hash code that determines the bucket.
-
---------
-- "=" --
---------
@@ -337,48 +328,6 @@ package body Ada.Containers.Hashed_Sets is
Position.Container := null;
end Delete;
- procedure Delete_Node
- (C : in out Set;
- Indx : Hash_Type;
- X : in out Node_Access)
- is
- HT : Hash_Table_Type renames C.HT;
- Prev : Node_Access;
- Curr : Node_Access;
-
- begin
- Prev := HT.Buckets (Indx);
- if Prev = X then
- HT.Buckets (Indx) := Next (Prev);
- HT.Length := HT.Length - 1;
- Free (X);
- return;
- end if;
-
- if HT.Length = 1 then
- raise Program_Error with
- "attempt to delete node not in its proper hash bucket";
- end if;
-
- loop
- Curr := Next (Prev);
-
- if Curr = null then
- raise Program_Error with
- "attempt to delete node not in its proper hash bucket";
- end if;
-
- if Curr = X then
- Set_Next (Node => Prev, Next => Next (Curr));
- HT.Length := HT.Length - 1;
- Free (X);
- return;
- end if;
- Prev := Curr;
- end loop;
-
- end Delete_Node;
-
----------------
-- Difference --
----------------
@@ -2138,8 +2087,8 @@ package body Ada.Containers.Hashed_Sets is
if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
then
- Delete_Node
- (Control.Container.all, Control.Index, Control.Old_Pos.Node);
+ HT_Ops.Delete_Node_At_Index
+ (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
raise Program_Error with "key not preserved in reference";
end if;
diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb
index f029c3b..d48afb3 100644
--- a/gcc/ada/a-elchha.adb
+++ b/gcc/ada/a-elchha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -53,10 +53,11 @@ is
pragma Import
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
- procedure Append_Info_Exception_Information
+ procedure Append_Info_Untailored_Exception_Information
(X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
pragma Import
- (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
+ (Ada, Append_Info_Untailored_Exception_Information,
+ "__gnat_append_info_u_e_info");
procedure To_Stderr (S : String);
pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
@@ -129,7 +130,7 @@ begin
To_Stderr ("Execution terminated by unhandled exception");
To_Stderr (Nline);
- Append_Info_Exception_Information (Except, Nobuf, Ptr);
+ Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr);
end if;
Unhandled_Terminate;
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 2cedb83..c09bc14 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -138,12 +138,17 @@ package body Ada.Exceptions is
-- to contain the indicated Id value and message. Message is a string
-- which is generated as the exception message.
- --------------------------------------
- -- Exception information subprogram --
- --------------------------------------
+ ---------------------------------------
+ -- Exception information subprograms --
+ ---------------------------------------
- function Exception_Information (X : Exception_Occurrence) return String;
- -- The format of the exception information is as follows:
+ function Untailored_Exception_Information
+ (X : Exception_Occurrence) return String;
+ -- This is used by Stream_Attributes.EO_To_String to convert an
+ -- Exception_Occurrence to a String for the stream attributes.
+ -- String_To_EO understands the format, as documented here.
+ --
+ -- The format of the string is as follows:
--
-- Exception_Name: <exception name> (as in Exception_Name)
-- Message: <message> (only if Exception_Message is empty)
@@ -164,10 +169,6 @@ package body Ada.Exceptions is
-- that an equivalent modification to the routine String_To_EO must be
-- made to preserve proper functioning of the stream attributes.
- ---------------------------------------
- -- Exception backtracing subprograms --
- ---------------------------------------
-
-- What is automatically output when exception tracing is on is the
-- usual exception information with the call chain backtrace possibly
-- tailored by a backtrace decorator. Modifying Exception_Information
@@ -177,28 +178,23 @@ package body Ada.Exceptions is
-- the possibly tailored output, which is equivalent if no decorator is
-- currently set:
- function Tailored_Exception_Information
- (X : Exception_Occurrence) return String;
- -- Exception information to be output in the case of automatic tracing
- -- requested through GNAT.Exception_Traces.
+ function Exception_Information (X : Exception_Occurrence) return String;
+ -- This is the implementation of Ada.Exceptions.Exception_Information,
+ -- as defined in the Ada RM.
--
- -- This is the same as Exception_Information if no backtrace decorator
- -- is currently in place. Otherwise, this is Exception_Information with
- -- the call chain raw addresses replaced by the result of a call to the
- -- current decorator provided with the call chain addresses.
-
- pragma Export
- (Ada, Tailored_Exception_Information,
- "__gnat_tailored_exception_information");
- -- This is currently used by System.Tasking.Stages
+ -- If no traceback decorator (see GNAT.Exception_Traces) is currently
+ -- in place, this is the same as Untailored_Exception_Information.
+ -- Otherwise, the decorator is used to produce a symbolic traceback
+ -- instead of hexadecimal addresses.
+ --
+ -- Note that unlike Untailored_Exception_Information, there is no need
+ -- to keep the output of Exception_Information stable for streaming
+ -- purposes, and in fact the output differs across platforms.
end Exception_Data;
package Exception_Traces is
- use Exception_Data;
- -- Imports Tailored_Exception_Information
-
----------------------------------------------
-- Run-Time Exception Notification Routines --
----------------------------------------------
@@ -737,8 +733,8 @@ package body Ada.Exceptions is
-- EO_To_String --
------------------
- -- We use the null string to represent the null occurrence, otherwise
- -- we output the Exception_Information string for the occurrence.
+ -- We use the null string to represent the null occurrence, otherwise we
+ -- output the Untailored_Exception_Information string for the occurrence.
function EO_To_String (X : Exception_Occurrence) return String
renames Stream_Attributes.EO_To_String;
diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb
index 2d496fb..f90858e 100644
--- a/gcc/ada/a-except.adb
+++ b/gcc/ada/a-except.adb
@@ -116,12 +116,17 @@ package body Ada.Exceptions is
-- message. Message is a string which is generated as the exception
-- message.
- --------------------------------------
- -- Exception information subprogram --
- --------------------------------------
+ ---------------------------------------
+ -- Exception information subprograms --
+ ---------------------------------------
- function Exception_Information (X : Exception_Occurrence) return String;
- -- The format of the exception information is as follows:
+ function Untailored_Exception_Information
+ (X : Exception_Occurrence) return String;
+ -- This is used by Stream_Attributes.EO_To_String to convert an
+ -- Exception_Occurrence to a String for the stream attributes.
+ -- String_To_EO understands the format, as documented here.
+ --
+ -- The format of the string is as follows:
--
-- Exception_Name: <exception name> (as in Exception_Name)
-- Message: <message> (only if Exception_Message is empty)
@@ -129,25 +134,19 @@ package body Ada.Exceptions is
-- Call stack traceback locations: (only if at least one location)
-- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
--
- -- The lines are separated by a ASCII.LF character
- --
- -- The nnnn is the partition Id given as decimal digits
- --
+ -- The lines are separated by a ASCII.LF character.
+ -- The nnnn is the partition Id given as decimal digits.
-- The 0x... line represents traceback program counter locations, in
-- execution order with the first one being the exception location. It
-- is present only
--
- -- The Exception_Name and Message lines are omitted in the abort signal
- -- case, since this is not really an exception.
+ -- The Exception_Name and Message lines are omitted in the abort
+ -- signal case, since this is not really an exception.
-- Note: If the format of the generated string is changed, please note
-- that an equivalent modification to the routine String_To_EO must be
-- made to preserve proper functioning of the stream attributes.
- ---------------------------------------
- -- Exception backtracing subprograms --
- ---------------------------------------
-
-- What is automatically output when exception tracing is on is the
-- usual exception information with the call chain backtrace possibly
-- tailored by a backtrace decorator. Modifying Exception_Information
@@ -157,28 +156,23 @@ package body Ada.Exceptions is
-- the possibly tailored output, which is equivalent if no decorator is
-- currently set:
- function Tailored_Exception_Information
- (X : Exception_Occurrence) return String;
- -- Exception information to be output in the case of automatic tracing
- -- requested through GNAT.Exception_Traces.
+ function Exception_Information (X : Exception_Occurrence) return String;
+ -- This is the implementation of Ada.Exceptions.Exception_Information,
+ -- as defined in the Ada RM.
--
- -- This is the same as Exception_Information if no backtrace decorator
- -- is currently in place. Otherwise, this is Exception_Information with
- -- the call chain raw addresses replaced by the result of a call to the
- -- current decorator provided with the call chain addresses.
-
- pragma Export
- (Ada, Tailored_Exception_Information,
- "__gnat_tailored_exception_information");
- -- This is currently used by System.Tasking.Stages
+ -- If no traceback decorator (see GNAT.Exception_Traces) is currently
+ -- in place, this is the same as Untailored_Exception_Information.
+ -- Otherwise, the decorator is used to produce a symbolic traceback
+ -- instead of hexadecimal addresses.
+ --
+ -- Note that unlike Untailored_Exception_Information, there is no need
+ -- to keep the output of Exception_Information stable for streaming
+ -- purposes, and in fact the output differs across platforms.
end Exception_Data;
package Exception_Traces is
- use Exception_Data;
- -- Imports Tailored_Exception_Information
-
----------------------------------------------
-- Run-Time Exception Notification Routines --
----------------------------------------------
@@ -774,7 +768,7 @@ package body Ada.Exceptions is
------------------
-- We use the null string to represent the null occurrence, otherwise we
- -- output the Exception_Information string for the occurrence.
+ -- output the Untailored_Exception_Information string for the occurrence.
function EO_To_String (X : Exception_Occurrence) return String
renames Stream_Attributes.EO_To_String;
@@ -806,9 +800,9 @@ package body Ada.Exceptions is
begin
if X.Id = Null_Id then
raise Constraint_Error;
+ else
+ return Exception_Data.Exception_Information (X);
end if;
-
- return Exception_Data.Exception_Information (X);
end Exception_Information;
-----------------------
diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb
index a201551..efe9b58 100644
--- a/gcc/ada/a-exexda.adb
+++ b/gcc/ada/a-exexda.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -36,39 +36,40 @@ package body Exception_Data is
-- This unit implements the Exception_Information related services for
-- both the Ada standard requirements and the GNAT.Exception_Traces
- -- facility.
+ -- facility. This is also used by the implementation of the stream
+ -- attributes of types Exception_Id and Exception_Occurrence.
-- There are common parts between the contents of Exception_Information
- -- (the regular Ada interface) and Tailored_Exception_Information (what
- -- the automatic backtracing output includes). The overall structure is
- -- sketched below:
+ -- (the regular Ada interface) and Untailored_Exception_Information (used
+ -- for streaming, and when there is no symbolic traceback available) The
+ -- overall structure is sketched below:
--
- -- Exception_Information
+ -- Untailored_Exception_Information
-- |
-- +-------+--------+
-- | |
- -- Basic_Exc_Info & Basic_Exc_Tback
- -- (B_E_I) (B_E_TB)
+ -- Basic_Exc_Info & Untailored_Exc_Tback
+ -- (B_E_I) (U_E_TB)
-- o--
-- (B_E_I) | Exception_Name: <exception name> (as in Exception_Name)
-- | Message: <message> (or a null line if no message)
-- | PID=nnnn (if != 0)
-- o--
- -- (B_E_TB) | Call stack traceback locations:
+ -- (U_E_TB) | Call stack traceback locations:
-- | <0xyyyyyyyy 0xyyyyyyyy ...>
-- o--
- -- Tailored_Exception_Information
+ -- Exception_Information
-- |
-- +----------+----------+
-- | |
- -- Basic_Exc_Info & Tailored_Exc_Tback
+ -- Basic_Exc_Info & traceback
-- |
-- +-----------+------------+
-- | |
- -- Basic_Exc_Tback Or Tback_Decorator
+ -- Untailored_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise
-- Functions returning String imply secondary stack use, which is a heavy
@@ -81,8 +82,8 @@ package body Exception_Data is
-- The procedural interface is composed of two major sections: a neutral
-- section for basic types like Address, Character, Natural or String, and
- -- an exception oriented section for the e.g. Basic_Exception_Information.
- -- This is the Append_Info family of procedures below.
+ -- an exception oriented section for the exception names, messages, and
+ -- information. This is the Append_Info family of procedures below.
-- Output to stderr is commanded by passing an empty buffer to update, and
-- care is taken not to overflow otherwise.
@@ -140,12 +141,12 @@ package body Exception_Data is
Info : in out String;
Ptr : in out Natural);
- procedure Append_Info_Basic_Exception_Traceback
+ procedure Append_Info_Untailored_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
- procedure Append_Info_Exception_Information
+ procedure Append_Info_Untailored_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural);
@@ -162,7 +163,7 @@ package body Exception_Data is
function Basic_Exception_Info_Maxlength
(X : Exception_Occurrence) return Natural;
- function Basic_Exception_Tback_Maxlength
+ function Untailored_Exception_Traceback_Maxlength
(X : Exception_Occurrence) return Natural;
function Exception_Info_Maxlength
@@ -181,11 +182,11 @@ package body Exception_Data is
-- Functional Interface --
--------------------------
- function Basic_Exception_Traceback
+ function Untailored_Exception_Traceback
(X : Exception_Occurrence) return String;
-- Returns an image of the complete call chain associated with an
-- exception occurrence in its most basic form, that is as a raw sequence
- -- of hexadecimal binary addresses.
+ -- of hexadecimal addresses.
function Tailored_Exception_Traceback
(X : Exception_Occurrence) return String;
@@ -201,7 +202,8 @@ package body Exception_Data is
(Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
pragma Export
- (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
+ (Ada, Append_Info_Untailored_Exception_Information,
+ "__gnat_append_info_u_e_info");
pragma Export
(Ada, Exception_Message_Length, "__gnat_exception_msg_len");
@@ -375,16 +377,16 @@ package body Exception_Data is
+ BEI_PID_Header'Length + 15;
end Basic_Exception_Info_Maxlength;
- -------------------------------------------
- -- Append_Info_Basic_Exception_Traceback --
- -------------------------------------------
+ ------------------------------------------------
+ -- Append_Info_Untailored_Exception_Traceback --
+ ------------------------------------------------
-- As for Basic_Exception_Information:
BETB_Header : constant String := "Call stack traceback locations:";
LDAD_Header : constant String := "Load address: ";
- procedure Append_Info_Basic_Exception_Traceback
+ procedure Append_Info_Untailored_Exception_Traceback
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
@@ -417,13 +419,13 @@ package body Exception_Data is
end loop;
Append_Info_NL (Info, Ptr);
- end Append_Info_Basic_Exception_Traceback;
+ end Append_Info_Untailored_Exception_Traceback;
- -----------------------------------------
- -- Basic_Exception_Traceback_Maxlength --
- -----------------------------------------
+ ----------------------------------------------
+ -- Untailored_Exception_Traceback_Maxlength --
+ ----------------------------------------------
- function Basic_Exception_Tback_Maxlength
+ function Untailored_Exception_Traceback_Maxlength
(X : Exception_Occurrence) return Natural
is
Space_Per_Address : constant := 2 + 16 + 1;
@@ -432,21 +434,21 @@ package body Exception_Data is
return
LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
X.Num_Tracebacks * Space_Per_Address + 1;
- end Basic_Exception_Tback_Maxlength;
+ end Untailored_Exception_Traceback_Maxlength;
- ---------------------------------------
- -- Append_Info_Exception_Information --
- ---------------------------------------
+ --------------------------------------------------
+ -- Append_Info_Untailored_Exception_Information --
+ --------------------------------------------------
- procedure Append_Info_Exception_Information
+ procedure Append_Info_Untailored_Exception_Information
(X : Exception_Occurrence;
Info : in out String;
Ptr : in out Natural)
is
begin
Append_Info_Basic_Exception_Information (X, Info, Ptr);
- Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
- end Append_Info_Exception_Information;
+ Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
+ end Append_Info_Untailored_Exception_Information;
------------------------------
-- Exception_Info_Maxlength --
@@ -458,7 +460,7 @@ package body Exception_Data is
begin
return
Basic_Exception_Info_Maxlength (X)
- + Basic_Exception_Tback_Maxlength (X);
+ + Untailored_Exception_Traceback_Maxlength (X);
end Exception_Info_Maxlength;
-----------------------------------
@@ -546,32 +548,33 @@ package body Exception_Data is
end Exception_Message_Length;
-------------------------------
- -- Basic_Exception_Traceback --
+ -- Untailored_Exception_Traceback --
-------------------------------
- function Basic_Exception_Traceback
+ function Untailored_Exception_Traceback
(X : Exception_Occurrence) return String
is
- Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
+ Info : aliased String
+ (1 .. Untailored_Exception_Traceback_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
- Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
+ Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
return Info (Info'First .. Ptr);
- end Basic_Exception_Traceback;
+ end Untailored_Exception_Traceback;
- ---------------------------
- -- Exception_Information --
- ---------------------------
+ --------------------------------------
+ -- Untailored_Exception_Information --
+ --------------------------------------
- function Exception_Information
+ function Untailored_Exception_Information
(X : Exception_Occurrence) return String
is
Info : String (1 .. Exception_Info_Maxlength (X));
Ptr : Natural := Info'First - 1;
begin
- Append_Info_Exception_Information (X, Info, Ptr);
+ Append_Info_Untailored_Exception_Information (X, Info, Ptr);
return Info (Info'First .. Ptr);
- end Exception_Information;
+ end Untailored_Exception_Information;
-------------------------
-- Set_Exception_C_Msg --
@@ -713,17 +716,17 @@ package body Exception_Data is
begin
if Wrapper = null then
- return Basic_Exception_Traceback (X);
+ return Untailored_Exception_Traceback (X);
else
return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
end if;
end Tailored_Exception_Traceback;
- ------------------------------------
- -- Tailored_Exception_Information --
- ------------------------------------
+ ---------------------------
+ -- Exception_Information --
+ ---------------------------
- function Tailored_Exception_Information
+ function Exception_Information
(X : Exception_Occurrence) return String
is
-- The tailored exception information is the basic information
@@ -739,6 +742,6 @@ package body Exception_Data is
Append_Info_Basic_Exception_Information (X, Info, Ptr);
Append_Info_String (Tback_Info, Info, Ptr);
return Info (Info'First .. Ptr);
- end Tailored_Exception_Information;
+ end Exception_Information;
end Exception_Data;
diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb
index fe4b706..94ec483 100644
--- a/gcc/ada/a-exextr.adb
+++ b/gcc/ada/a-exextr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -99,7 +99,7 @@ package body Exception_Traces is
To_Stderr ("Exception raised");
To_Stderr (Nline);
- To_Stderr (Tailored_Exception_Information (Excep.all));
+ To_Stderr (Exception_Information (Excep.all));
Unlock_Task.all;
end if;
diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb
index f8f75b2..cd7565f 100644
--- a/gcc/ada/a-exstat.adb
+++ b/gcc/ada/a-exstat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
@@ -59,15 +59,15 @@ package body Stream_Attributes is
-- EO_To_String --
------------------
- -- We use the null string to represent the null occurrence, otherwise
- -- we output the Exception_Information string for the occurrence.
+ -- We use the null string to represent the null occurrence, otherwise we
+ -- output the Untailored_Exception_Information string for the occurrence.
function EO_To_String (X : Exception_Occurrence) return String is
begin
if X.Id = Null_Id then
return "";
else
- return Exception_Information (X);
+ return Exception_Data.Untailored_Exception_Information (X);
end if;
end EO_To_String;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 27862d5..4de06a4 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -61,7 +61,6 @@ with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Urealp; use Urealp;
with Validsw; use Validsw;
package body Checks is
@@ -4076,18 +4075,20 @@ package body Checks is
type Cache_Index is range 0 .. Cache_Size - 1;
-- Determine size of below cache (power of 2 is more efficient)
- Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
- Determine_Range_Cache_V : array (Cache_Index) of Boolean;
- Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
- Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
+ Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
+ Determine_Range_Cache_V : array (Cache_Index) of Boolean;
+ Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
+ Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
+ Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
+ Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
-- The above arrays are used to implement a small direct cache for
- -- Determine_Range calls. Because of the way Determine_Range recursively
- -- traces subexpressions, and because overflow checking calls the routine
- -- on the way up the tree, a quadratic behavior can otherwise be
- -- encountered in large expressions. The cache entry for node N is stored
- -- in the (N mod Cache_Size) entry, and can be validated by checking the
- -- actual node value stored there. The Range_Cache_V array records the
- -- setting of Assume_Valid for the cache entry.
+ -- Determine_Range and Determine_Range_R calls. Because of the way these
+ -- subprograms recursively traces subexpressions, and because overflow
+ -- checking calls the routine on the way up the tree, a quadratic behavior
+ -- can otherwise be encountered in large expressions. The cache entry for
+ -- node N is stored in the (N mod Cache_Size) entry, and can be validated
+ -- by checking the actual node value stored there. The Range_Cache_V array
+ -- records the setting of Assume_Valid for the cache entry.
procedure Determine_Range
(N : Node_Id;
@@ -4544,7 +4545,7 @@ package body Checks is
if OK1 then
-- If the refined value of the low bound is greater than the type
- -- high bound, then reset it to the more restrictive value. However,
+ -- low bound, then reset it to the more restrictive value. However,
-- we do NOT do this for the case of a modular type where the
-- possible upper bound on the value is above the base type high
-- bound, because that means the result could wrap.
@@ -4596,6 +4597,427 @@ package body Checks is
end if;
end Determine_Range;
+ -----------------------
+ -- Determine_Range_R --
+ -----------------------
+
+ procedure Determine_Range_R
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Ureal;
+ Hi : out Ureal;
+ Assume_Valid : Boolean := False)
+ is
+ Typ : Entity_Id := Etype (N);
+ -- Type to use, may get reset to base type for possibly invalid entity
+
+ Lo_Left : Ureal;
+ Hi_Left : Ureal;
+ -- Lo and Hi bounds of left operand
+
+ Lo_Right : Ureal;
+ Hi_Right : Ureal;
+ -- Lo and Hi bounds of right (or only) operand
+
+ Bound : Node_Id;
+ -- Temp variable used to hold a bound node
+
+ Hbound : Ureal;
+ -- High bound of base type of expression
+
+ Lor : Ureal;
+ Hir : Ureal;
+ -- Refined values for low and high bounds, after tightening
+
+ OK1 : Boolean;
+ -- Used in lower level calls to indicate if call succeeded
+
+ Cindex : Cache_Index;
+ -- Used to search cache
+
+ Btyp : Entity_Id;
+ -- Base type
+
+ function OK_Operands return Boolean;
+ -- Used for binary operators. Determines the ranges of the left and
+ -- right operands, and if they are both OK, returns True, and puts
+ -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
+
+ function Round_Machine (B : Ureal) return Ureal;
+ -- B is a real bound. Round it using mode Round_Even.
+
+ -----------------
+ -- OK_Operands --
+ -----------------
+
+ function OK_Operands return Boolean is
+ begin
+ Determine_Range_R
+ (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
+
+ if not OK1 then
+ return False;
+ end if;
+
+ Determine_Range_R
+ (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
+ return OK1;
+ end OK_Operands;
+
+ -------------------
+ -- Round_Machine --
+ -------------------
+
+ function Round_Machine (B : Ureal) return Ureal is
+ begin
+ return Machine (Typ, B, Round_Even, N);
+ end Round_Machine;
+
+ -- Start of processing for Determine_Range_R
+
+ begin
+ -- Prevent junk warnings by initializing range variables
+
+ Lo := No_Ureal;
+ Hi := No_Ureal;
+ Lor := No_Ureal;
+ Hir := No_Ureal;
+
+ -- For temporary constants internally generated to remove side effects
+ -- we must use the corresponding expression to determine the range of
+ -- the expression. But note that the expander can also generate
+ -- constants in other cases, including deferred constants.
+
+ if Is_Entity_Name (N)
+ and then Nkind (Parent (Entity (N))) = N_Object_Declaration
+ and then Ekind (Entity (N)) = E_Constant
+ and then Is_Internal_Name (Chars (Entity (N)))
+ then
+ if Present (Expression (Parent (Entity (N)))) then
+ Determine_Range_R
+ (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
+
+ elsif Present (Full_View (Entity (N))) then
+ Determine_Range_R
+ (Expression (Parent (Full_View (Entity (N)))),
+ OK, Lo, Hi, Assume_Valid);
+
+ else
+ OK := False;
+ end if;
+ return;
+ end if;
+
+ -- If type is not defined, we can't determine its range
+
+ if No (Typ)
+
+ -- We don't deal with anything except IEEE floating-point types
+
+ or else not Is_Floating_Point_Type (Typ)
+ or else Float_Rep (Typ) /= IEEE_Binary
+
+ -- Ignore type for which an error has been posted, since range in
+ -- this case may well be a bogosity deriving from the error. Also
+ -- ignore if error posted on the reference node.
+
+ or else Error_Posted (N) or else Error_Posted (Typ)
+ then
+ OK := False;
+ return;
+ end if;
+
+ -- For all other cases, we can determine the range
+
+ OK := True;
+
+ -- If value is compile time known, then the possible range is the one
+ -- value that we know this expression definitely has.
+
+ if Compile_Time_Known_Value (N) then
+ Lo := Expr_Value_R (N);
+ Hi := Lo;
+ return;
+ end if;
+
+ -- Return if already in the cache
+
+ Cindex := Cache_Index (N mod Cache_Size);
+
+ if Determine_Range_Cache_N (Cindex) = N
+ and then
+ Determine_Range_Cache_V (Cindex) = Assume_Valid
+ then
+ Lo := Determine_Range_Cache_Lo_R (Cindex);
+ Hi := Determine_Range_Cache_Hi_R (Cindex);
+ return;
+ end if;
+
+ -- Otherwise, start by finding the bounds of the type of the expression,
+ -- the value cannot be outside this range (if it is, then we have an
+ -- overflow situation, which is a separate check, we are talking here
+ -- only about the expression value).
+
+ -- First a check, never try to find the bounds of a generic type, since
+ -- these bounds are always junk values, and it is only valid to look at
+ -- the bounds in an instance.
+
+ if Is_Generic_Type (Typ) then
+ OK := False;
+ return;
+ end if;
+
+ -- First step, change to use base type unless we know the value is valid
+
+ if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
+ or else Assume_No_Invalid_Values
+ or else Assume_Valid
+ then
+ null;
+ else
+ Typ := Underlying_Type (Base_Type (Typ));
+ end if;
+
+ -- Retrieve the base type. Handle the case where the base type is a
+ -- private type.
+
+ Btyp := Base_Type (Typ);
+
+ if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
+ Btyp := Full_View (Btyp);
+ end if;
+
+ -- We use the actual bound unless it is dynamic, in which case use the
+ -- corresponding base type bound if possible. If we can't get a bound
+ -- then we figure we can't determine the range (a peculiar case, that
+ -- perhaps cannot happen, but there is no point in bombing in this
+ -- optimization circuit).
+
+ -- First the low bound
+
+ Bound := Type_Low_Bound (Typ);
+
+ if Compile_Time_Known_Value (Bound) then
+ Lo := Expr_Value_R (Bound);
+
+ elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
+ Lo := Expr_Value_R (Type_Low_Bound (Btyp));
+
+ else
+ OK := False;
+ return;
+ end if;
+
+ -- Now the high bound
+
+ Bound := Type_High_Bound (Typ);
+
+ -- We need the high bound of the base type later on, and this should
+ -- always be compile time known. Again, it is not clear that this
+ -- can ever be false, but no point in bombing.
+
+ if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
+ Hbound := Expr_Value_R (Type_High_Bound (Btyp));
+ Hi := Hbound;
+
+ else
+ OK := False;
+ return;
+ end if;
+
+ -- If we have a static subtype, then that may have a tighter bound so
+ -- use the upper bound of the subtype instead in this case.
+
+ if Compile_Time_Known_Value (Bound) then
+ Hi := Expr_Value_R (Bound);
+ end if;
+
+ -- We may be able to refine this value in certain situations. If any
+ -- refinement is possible, then Lor and Hir are set to possibly tighter
+ -- bounds, and OK1 is set to True.
+
+ case Nkind (N) is
+
+ -- For unary plus, result is limited by range of operand
+
+ when N_Op_Plus =>
+ Determine_Range_R
+ (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
+
+ -- For unary minus, determine range of operand, and negate it
+
+ when N_Op_Minus =>
+ Determine_Range_R
+ (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
+
+ if OK1 then
+ Lor := -Hi_Right;
+ Hir := -Lo_Right;
+ end if;
+
+ -- For binary addition, get range of each operand and do the
+ -- addition to get the result range.
+
+ when N_Op_Add =>
+ if OK_Operands then
+ Lor := Round_Machine (Lo_Left + Lo_Right);
+ Hir := Round_Machine (Hi_Left + Hi_Right);
+ end if;
+
+ -- For binary subtraction, get range of each operand and do the worst
+ -- case subtraction to get the result range.
+
+ when N_Op_Subtract =>
+ if OK_Operands then
+ Lor := Round_Machine (Lo_Left - Hi_Right);
+ Hir := Round_Machine (Hi_Left - Lo_Right);
+ end if;
+
+ -- For multiplication, get range of each operand and do the
+ -- four multiplications to get the result range.
+
+ when N_Op_Multiply =>
+ if OK_Operands then
+ declare
+ M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
+ M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
+ M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
+ M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
+ begin
+ Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
+ Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
+ end;
+ end if;
+
+ -- For division, consider separately the cases where the right
+ -- operand is positive or negative. Otherwise, the right operand
+ -- can be arbitrarily close to zero, so the result is likely to
+ -- be unbounded in one direction, do not attempt to compute it.
+
+ when N_Op_Divide =>
+ if OK_Operands then
+
+ -- Right operand is positive
+
+ if Lo_Right > Ureal_0 then
+
+ -- If the low bound of the left operand is negative, obtain
+ -- the overall low bound by dividing it by the smallest
+ -- value of the right operand, and otherwise by the largest
+ -- value of the right operand.
+
+ if Lo_Left < Ureal_0 then
+ Lor := Round_Machine (Lo_Left / Lo_Right);
+ else
+ Lor := Round_Machine (Lo_Left / Hi_Right);
+ end if;
+
+ -- If the high bound of the left operand is negative, obtain
+ -- the overall high bound by dividing it by the largest
+ -- value of the right operand, and otherwise by the
+ -- smallest value of the right operand.
+
+ if Hi_Left < Ureal_0 then
+ Hir := Round_Machine (Hi_Left / Hi_Right);
+ else
+ Hir := Round_Machine (Hi_Left / Lo_Right);
+ end if;
+
+ -- Right operand is negative
+
+ elsif Hi_Right < Ureal_0 then
+
+ -- If the low bound of the left operand is negative, obtain
+ -- the overall low bound by dividing it by the largest
+ -- value of the right operand, and otherwise by the smallest
+ -- value of the right operand.
+
+ if Lo_Left < Ureal_0 then
+ Lor := Round_Machine (Lo_Left / Hi_Right);
+ else
+ Lor := Round_Machine (Lo_Left / Lo_Right);
+ end if;
+
+ -- If the high bound of the left operand is negative, obtain
+ -- the overall high bound by dividing it by the smallest
+ -- value of the right operand, and otherwise by the
+ -- largest value of the right operand.
+
+ if Hi_Left < Ureal_0 then
+ Hir := Round_Machine (Hi_Left / Lo_Right);
+ else
+ Hir := Round_Machine (Hi_Left / Hi_Right);
+ end if;
+
+ else
+ OK1 := False;
+ end if;
+ end if;
+
+ -- For type conversion from one floating-point type to another, we
+ -- can refine the range using the converted value.
+
+ when N_Type_Conversion =>
+ Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
+
+ -- Nothing special to do for all other expression kinds
+
+ when others =>
+ OK1 := False;
+ Lor := No_Ureal;
+ Hir := No_Ureal;
+ end case;
+
+ -- At this stage, if OK1 is true, then we know that the actual result of
+ -- the computed expression is in the range Lor .. Hir. We can use this
+ -- to restrict the possible range of results.
+
+ if OK1 then
+
+ -- If the refined value of the low bound is greater than the type
+ -- low bound, then reset it to the more restrictive value.
+
+ if Lor > Lo then
+ Lo := Lor;
+ end if;
+
+ -- Similarly, if the refined value of the high bound is less than the
+ -- value so far, then reset it to the more restrictive value.
+
+ if Hir < Hi then
+ Hi := Hir;
+ end if;
+ end if;
+
+ -- Set cache entry for future call and we are all done
+
+ Determine_Range_Cache_N (Cindex) := N;
+ Determine_Range_Cache_V (Cindex) := Assume_Valid;
+ Determine_Range_Cache_Lo_R (Cindex) := Lo;
+ Determine_Range_Cache_Hi_R (Cindex) := Hi;
+ return;
+
+ -- If any exception occurs, it means that we have some bug in the compiler,
+ -- possibly triggered by a previous error, or by some unforeseen peculiar
+ -- occurrence. However, this is only an optimization attempt, so there is
+ -- really no point in crashing the compiler. Instead we just decide, too
+ -- bad, we can't figure out a range in this case after all.
+
+ exception
+ when others =>
+
+ -- Debug flag K disables this behavior (useful for debugging)
+
+ if Debug_Flag_K then
+ raise;
+ else
+ OK := False;
+ Lo := No_Ureal;
+ Hi := No_Ureal;
+ return;
+ end if;
+ end Determine_Range_R;
+
------------------------------------
-- Discriminant_Checks_Suppressed --
------------------------------------
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 3f4f387..56dcbf5 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -40,6 +40,7 @@ with Namet; use Namet;
with Table;
with Types; use Types;
with Uintp; use Uintp;
+with Urealp; use Urealp;
package Checks is
@@ -302,6 +303,18 @@ package Checks is
-- then this assumption is valid, if False, then processing is done using
-- base types to allow invalid values.
+ procedure Determine_Range_R
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Ureal;
+ Hi : out Ureal;
+ Assume_Valid : Boolean := False);
+ -- Similar to Determine_Range, but for a node N of floating-point type. OK
+ -- is True on return only for IEEE floating-point types and only if we do
+ -- not have to worry about extended precision (i.e. on the x86, we must be
+ -- using -msse2 -mfpmath=sse. At the current time, this is used only in
+ -- GNATprove, though we could consider using it more generally in future.
+
procedure Install_Null_Excluding_Check (N : Node_Id);
-- Determines whether an access node requires a runtime access check and
-- if so inserts the appropriate run-time check.
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index beb5f45..d19ca28 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -5345,10 +5345,11 @@ package body Exp_Aggr is
-- then we could go into an infinite recursion.
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
- and then not AAMP_On_Target
and then VM_Target = No_VM
+ and then not AAMP_On_Target
and then not Generate_SCIL
and then not Possible_Bit_Aligned_Component (Target)
+ and then not Is_Possibly_Unaligned_Slice (Target)
and then Aggr_Assignment_OK_For_Backend (N)
then
if Maybe_In_Place_OK then
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 4a68d1d..6c2adba 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -5041,18 +5041,6 @@ package body Exp_Util is
return False;
end if;
- -- Always assume the worst for a nested record component with a
- -- component clause, which gigi/gcc does not appear to handle well.
- -- It is not clear why this special test is needed at all ???
-
- if Nkind (Prefix (N)) = N_Selected_Component
- and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
- and then
- Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
- then
- return True;
- end if;
-
-- We only need to worry if the target has strict alignment
if not Target_Strict_Alignment then
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index 77fb65b..46a4be5 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -1524,12 +1524,6 @@ package body System.Tasking.Stages is
Ada.Unchecked_Conversion
(Task_Id, System.Task_Primitives.Task_Address);
- function Tailored_Exception_Information
- (E : Exception_Occurrence) return String;
- pragma Import
- (Ada, Tailored_Exception_Information,
- "__gnat_tailored_exception_information");
-
Excep : constant Exception_Occurrence_Access :=
SSL.Get_Current_Excep.all;
@@ -1553,7 +1547,7 @@ package body System.Tasking.Stages is
To_Stderr (System.Address_Image (To_Address (Self_Id)));
To_Stderr (" terminated by unhandled exception");
To_Stderr ((1 => ASCII.LF));
- To_Stderr (Tailored_Exception_Information (Excep.all));
+ To_Stderr (Exception_Information (Excep.all));
Initialization.Task_Unlock (Self_Id);
end Trace_Unhandled_Exception_In_Task;