diff options
-rw-r--r-- | gcc/ada/ChangeLog | 58 | ||||
-rw-r--r-- | gcc/ada/a-cborse.adb | 87 | ||||
-rw-r--r-- | gcc/ada/a-cborse.ads | 26 | ||||
-rw-r--r-- | gcc/ada/a-chtgop.adb | 47 | ||||
-rw-r--r-- | gcc/ada/a-chtgop.ads | 12 | ||||
-rw-r--r-- | gcc/ada/a-cihase.adb | 91 | ||||
-rw-r--r-- | gcc/ada/a-cihase.ads | 27 | ||||
-rw-r--r-- | gcc/ada/a-cohase.adb | 55 | ||||
-rw-r--r-- | gcc/ada/a-elchha.adb | 9 | ||||
-rw-r--r-- | gcc/ada/a-except-2005.adb | 50 | ||||
-rw-r--r-- | gcc/ada/a-except.adb | 62 | ||||
-rw-r--r-- | gcc/ada/a-exexda.adb | 111 | ||||
-rw-r--r-- | gcc/ada/a-exextr.adb | 4 | ||||
-rw-r--r-- | gcc/ada/a-exstat.adb | 8 | ||||
-rw-r--r-- | gcc/ada/checks.adb | 448 | ||||
-rw-r--r-- | gcc/ada/checks.ads | 13 | ||||
-rw-r--r-- | gcc/ada/exp_aggr.adb | 3 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 12 | ||||
-rw-r--r-- | gcc/ada/s-tassta.adb | 8 |
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; |