+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,
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");
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);
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 --
-------------
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 --
----------
(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
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;
-- 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,
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);
-- --
-- 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- --
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 --
---------------------------
-- --
-- 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- --
-- 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);
-- --
-- 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- --
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 --
------------------------
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 --
----------
(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
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;
-------------
-- --
-- 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 --
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;
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.
-
---------
-- "=" --
---------
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 --
----------------
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;
-- --
-- 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- --
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");
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;
-- 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)
-- 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
-- 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 --
----------------------------------------------
-- 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;
-- 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)
-- 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
-- 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 --
----------------------------------------------
------------------
-- 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;
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;
-----------------------
-- --
-- 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- --
-- 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
-- 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.
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);
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
-- 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;
(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");
+ 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)
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;
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 --
begin
return
Basic_Exception_Info_Maxlength (X)
- + Basic_Exception_Tback_Maxlength (X);
+ + Untailored_Exception_Traceback_Maxlength (X);
end Exception_Info_Maxlength;
-----------------------------------
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 --
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
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;
-- --
-- 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- --
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;
-- --
-- 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- --
-- 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;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Urealp; use Urealp;
with Validsw; use Validsw;
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;
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.
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 --
------------------------------------
with Table;
with Types; use Types;
with Uintp; use Uintp;
+with Urealp; use Urealp;
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.
-- 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
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
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;
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;
projects / gcc.git / commitdiff