diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-chtgop.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/a-chtgop.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.adb | 43 | ||||
| -rw-r--r-- | gcc/ada/a-elchha.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 78 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/a-exexda.adb | 337 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 2 |
14 files changed, 328 insertions, 327 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8db9279cfd0..ee7d601b393 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2014-07-30 Robert Dewar <dewar@adacore.com> + + * checks.adb, a-cihase.adb, a-cihase.ads, a-chtgop.adb, a-chtgop.ads, + a-except.adb, a-except-2005.adb, a-cborse.adb, a-cborse.ads, + a-exexda.adb, a-elchha.adb, exp_aggr.adb, a-cohase.adb: Minor + reformatting. + 2014-07-30 Ed Schonberg <schonberg@adacore.com> * a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index db9c8c69e5b..ffb06a12d53 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -991,18 +991,17 @@ package body Ada.Containers.Bounded_Ordered_Sets is L : Natural renames Container.Lock; begin return R : constant Reference_Type := - (Element => N.Element'Access, - Control => - (Controlled with - Container => Container'Access, - Pos => Position, - Old_Key => new Key_Type'(Key (Position)))) + (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 @@ -1022,17 +1021,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is L : Natural renames Container.Lock; begin 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))) + (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; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index aee0bf968a1..09cb6510b2c 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -292,12 +292,10 @@ package Ada.Containers.Bounded_Ordered_Sets is Old_Key : Key_Access; end record; - overriding procedure - Adjust (Control : in out Reference_Control_Type); + overriding procedure Adjust (Control : in out Reference_Control_Type); pragma Inline (Adjust); - overriding procedure - Finalize (Control : in out Reference_Control_Type); + overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); type Reference_Type (Element : not null access Element_Type) is record diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 2b3fbd333ff..dda5f2cccf7 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -209,6 +209,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is begin Prev := HT.Buckets (Indx); + if Prev = X then HT.Buckets (Indx) := Next (Prev); HT.Length := HT.Length - 1; @@ -235,11 +236,11 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Free (X); return; end if; + Prev := Curr; end loop; + end Delete_Node_At_Index; - end Delete_Node_At_Index -; --------------------------- -- Delete_Node_Sans_Free -- --------------------------- diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index 994f520fcc3..70e1535c86a 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -129,10 +129,9 @@ package Ada.Containers.Hash_Tables.Generic_Operations 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); - + (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 @@ -173,8 +172,9 @@ package Ada.Containers.Hash_Tables.Generic_Operations is generic use Ada.Streams; - with function New_Node (Stream : not null access Root_Stream_Type'Class) - return Node_Access; + with function New_Node + (Stream : not null access Root_Stream_Type'Class) + return Node_Access; procedure Generic_Read (Stream : not null access Root_Stream_Type'Class; HT : out Hash_Table_Type); @@ -184,7 +184,7 @@ package Ada.Containers.Hash_Tables.Generic_Operations is function New_Buckets (Length : Hash_Type) return Buckets_Access; pragma Inline (New_Buckets); - -- Allocate a new Buckets_Type array with bounds 0..Length-1 + -- Allocate a new Buckets_Type array with bounds 0 .. Length - 1 procedure Free_Buckets (Buckets : in out Buckets_Access); pragma Inline (Free_Buckets); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 44d3dc14516..7d503668702 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -2148,8 +2148,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is if Control.Container /= null then declare HT : Hash_Table_Type renames Control.Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin B := B + 1; L := L + 1; @@ -2275,9 +2275,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets 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; + 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; @@ -2285,7 +2285,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is 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); + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); raise Program_Error; end if; @@ -2368,19 +2368,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; 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 + (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; @@ -2391,8 +2390,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Container : aliased in out Set; Key : Key_Type) return Reference_Type is - Node : constant Node_Access := - Key_Keys.Find (Container.HT, Key); + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin if Node = null then @@ -2405,19 +2403,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - P : constant Cursor := Find (Container, Key); - + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + P : constant Cursor := Find (Container, Key); 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))) + (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; @@ -2434,8 +2431,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key : Key_Type; New_Item : Element_Type) is - Node : constant Node_Access := - Key_Keys.Find (Container.HT, Key); + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin if Node = null then diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index 86eb4d05f2c..05af6bf32ed 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -442,16 +442,14 @@ package Ada.Containers.Indefinite_Hashed_Sets is Old_Hash : Hash_Type; end record; - overriding procedure - Adjust (Control : in out Reference_Control_Type); + overriding procedure Adjust (Control : in out Reference_Control_Type); pragma Inline (Adjust); - overriding procedure - Finalize (Control : in out Reference_Control_Type); + 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; + Control : Reference_Control_Type; end record; use Ada.Streams; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 841cec2706b..f7f49aab96c 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -2078,8 +2078,8 @@ package body Ada.Containers.Hashed_Sets is if Control.Container /= null then declare HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin B := B - 1; L := L - 1; @@ -2088,7 +2088,7 @@ package body Ada.Containers.Hashed_Sets is if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash then HT_Ops.Delete_Node_At_Index - (Control.Container.HT, Control.Index, Control.Old_Pos.Node); + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); raise Program_Error with "key not preserved in reference"; end if; @@ -2106,13 +2106,12 @@ package body Ada.Containers.Hashed_Sets is is HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; Node : constant Node_Access := Key_Keys.Find (HT, Key); - begin if Node = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); end if; - - return Cursor'(Container'Unrestricted_Access, Node); end Find; --------- @@ -2167,17 +2166,17 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => - (Controlled with - Container'Unrestricted_Access, - Index => HT_Ops.Index (HT, Position.Node), - Old_Pos => Position, - Old_Hash => Hash (Key (Position)))) + (Element => Position.Node.Element'Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, Position.Node), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) do B := B + 1; L := L + 1; @@ -2203,13 +2202,13 @@ package body Ada.Containers.Hashed_Sets is P : constant Cursor := Find (Container, Key); begin return R : constant Reference_Type := - (Element => Node.Element'Access, - Control => - (Controlled with - Container'Unrestricted_Access, - Index => HT_Ops.Index (HT, P.Node), - Old_Pos => P, - Old_Hash => Hash (Key))) + (Element => Node.Element'Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, P.Node), + Old_Pos => P, + Old_Hash => Hash (Key))) do B := B + 1; L := L + 1; diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb index d48afb332c1..6ef2e0339f2 100644 --- a/gcc/ada/a-elchha.adb +++ b/gcc/ada/a-elchha.adb @@ -49,12 +49,16 @@ is pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); procedure Append_Info_Exception_Message - (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); pragma Import (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); procedure Append_Info_Untailored_Exception_Information - (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); pragma Import (Ada, Append_Info_Untailored_Exception_Information, "__gnat_append_info_u_e_info"); diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index c09bc14f3f8..85adb7c4a1e 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -74,14 +74,14 @@ package body Ada.Exceptions is -- These procedures are used to provide exclusion bounds in -- calls to Call_Chain at exception raise points from this unit. The -- purpose is to arrange for the exception tracebacks not to include - -- frames from routines involved in the raise process, as these are + -- frames from subprograms involved in the raise process, as these are -- meaningless from the user's standpoint. -- -- For these bounds to be meaningful, we need to ensure that the object - -- code for the routines involved in processing a raise is located after - -- the object code Code_Address_For_AAA and before the object code - -- Code_Address_For_ZZZ. This will indeed be the case as long as the - -- following rules are respected: + -- code for the subprograms involved in processing a raise is located + -- after the object code Code_Address_For_AAA and before the object + -- code Code_Address_For_ZZZ. This will indeed be the case as long as + -- the following rules are respected: -- -- 1) The bodies of the subprograms involved in processing a raise -- are located after the body of Code_Address_For_AAA and before the @@ -111,9 +111,9 @@ package body Ada.Exceptions is package Exception_Data is - --------------------------------- - -- Exception messages routines -- - --------------------------------- + ----------------------------------- + -- Exception Message Subprograms -- + ----------------------------------- procedure Set_Exception_C_Msg (Excep : EOA; @@ -139,7 +139,7 @@ package body Ada.Exceptions is -- which is generated as the exception message. --------------------------------------- - -- Exception information subprograms -- + -- Exception Information Subprograms -- --------------------------------------- function Untailored_Exception_Information @@ -164,17 +164,17 @@ package body Ada.Exceptions is -- -- 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. - + -- -- 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 -- itself is not a good idea because the decorated output is completely -- out of control and would break all our code related to the streaming - -- of exceptions. We then provide an alternative function to compute + -- of exceptions. We then provide an alternative function to compute -- the possibly tailored output, which is equivalent if no decorator is -- currently set: @@ -195,9 +195,9 @@ package body Ada.Exceptions is package Exception_Traces is - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- + ------------------------------------------------- + -- Run-Time Exception Notification Subprograms -- + ------------------------------------------------- -- These subprograms provide a common run-time interface to trigger the -- actions required when an exception is about to be propagated (e.g. @@ -229,9 +229,9 @@ package body Ada.Exceptions is package Exception_Propagation is - ------------------------------------ - -- Exception propagation routines -- - ------------------------------------ + --------------------------------------- + -- Exception Propagation Subprograms -- + --------------------------------------- function Allocate_Occurrence return EOA; -- Allocate an exception occurence (as well as the machine occurence) @@ -244,9 +244,9 @@ package body Ada.Exceptions is package Stream_Attributes is - -------------------------------- - -- Stream attributes routines -- - -------------------------------- + ---------------------------------- + -- Stream Attribute Subprograms -- + ---------------------------------- function EId_To_String (X : Exception_Id) return String; function String_To_EId (S : String) return Exception_Id; @@ -392,11 +392,11 @@ package body Ada.Exceptions is -- Source as an exception to be propagated in the caller task. Target is -- expected to be a pointer to the fixed TSD occurrence for this task. - ----------------------------- - -- Run-Time Check Routines -- - ----------------------------- + -------------------------------- + -- Run-Time Check Subprograms -- + -------------------------------- - -- These routines raise a specific exception with a reason message + -- These subprograms raise a specific exception with a reason message -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. @@ -486,7 +486,7 @@ package body Ada.Exceptions is -- This routine is separated out because it has quite different behavior -- from the others. This is the "finalize/adjust raised exception". This -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer. + -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. pragma Export (C, Rcheck_CE_Access_Check, "__gnat_rcheck_CE_Access_Check"); @@ -1207,9 +1207,9 @@ package body Ada.Exceptions is Complete_And_Propagate_Occurrence (Excep); end Raise_With_Msg; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- + ----------------------------------------- + -- Calls to Run-Time Check Subprograms -- + ----------------------------------------- procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer) @@ -1474,9 +1474,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF & - "index " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF + & "index " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Index_Check_Ext; @@ -1485,9 +1485,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF & - "value " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Invalid_Data_Ext; @@ -1496,9 +1496,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF & - "value " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Range_Check_Ext; @@ -1510,7 +1510,7 @@ package body Ada.Exceptions is begin -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* routines, it + -- called with abort deferred, unlike all other Rcheck_* subprograms, it -- needs to call Raise_Exception_No_Defer. -- This is consistent with Raise_From_Controlled_Operation diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index f90858e1937..e7590085180 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -88,9 +88,9 @@ package body Ada.Exceptions is package Exception_Data is - --------------------------------- - -- Exception messages routines -- - --------------------------------- + ----------------------------------- + -- Exception Message Subprograms -- + ----------------------------------- procedure Set_Exception_C_Msg (Excep : EOA; @@ -117,7 +117,7 @@ package body Ada.Exceptions is -- message. --------------------------------------- - -- Exception information subprograms -- + -- Exception Information Subprograms -- --------------------------------------- function Untailored_Exception_Information @@ -142,17 +142,17 @@ package body Ada.Exceptions is -- -- 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. - + -- -- 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 -- itself is not a good idea because the decorated output is completely -- out of control and would break all our code related to the streaming - -- of exceptions. We then provide an alternative function to compute + -- of exceptions. We then provide an alternative function to compute -- the possibly tailored output, which is equivalent if no decorator is -- currently set: @@ -173,9 +173,9 @@ package body Ada.Exceptions is package Exception_Traces is - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- + ------------------------------------------------- + -- Run-Time Exception Notification Subprograms -- + ------------------------------------------------- -- These subprograms provide a common run-time interface to trigger the -- actions required when an exception is about to be propagated (e.g. @@ -207,9 +207,9 @@ package body Ada.Exceptions is package Stream_Attributes is - -------------------------------- - -- Stream attributes routines -- - -------------------------------- + ---------------------------------- + -- Stream Attribute Subprograms -- + ---------------------------------- function EId_To_String (X : Exception_Id) return String; function String_To_EId (S : String) return Exception_Id; @@ -232,7 +232,8 @@ package body Ada.Exceptions is -- about it. procedure Raise_Exception_No_Defer - (E : Exception_Id; Message : String := ""); + (E : Exception_Id; + Message : String := ""); pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); @@ -346,18 +347,18 @@ package body Ada.Exceptions is -- caller task. Target is expected to be a pointer to the fixed TSD -- occurrence for this task. - ----------------------------- - -- Run-Time Check Routines -- - ----------------------------- + -------------------------------- + -- Run-Time Check Subprograms -- + -------------------------------- - -- These routines raise a specific exception with a reason message + -- These subprograms raise a specific exception with a reason message -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - -- Note on ordering of these routines. Normally in the Ada.Exceptions units - -- we don't care about the ordering of entries for Rcheck routines, and - -- the normal approach is to keep them in the same order as declarations - -- in Types. + -- Note on ordering of these subprograms. Normally in the Ada.Exceptions + -- units we do not care about the ordering of entries for Rcheck + -- subprograms, and the normal approach is to keep them in the same + -- order as declarations in Types. -- This section is an IMPORTANT EXCEPTION. It is required by the .Net -- runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the @@ -443,7 +444,7 @@ package body Ada.Exceptions is -- This routine is separated out because it has quite different behavior -- from the others. This is the "finalize/adjust raised exception". This -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer. + -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. pragma Export (C, Rcheck_CE_Access_Check, "__gnat_rcheck_CE_Access_Check"); @@ -1184,9 +1185,9 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_With_Msg; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- + ----------------------------------------- + -- Calls to Run-Time Check Subprograms -- + ----------------------------------------- procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer) @@ -1445,10 +1446,11 @@ package body Ada.Exceptions is is E : constant Exception_Id := Program_Error_Def'Access; Excep : constant EOA := Get_Current_Excep.all; + begin -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* routines, it - -- needs to call Raise_Exception_No_Defer. + -- called with abort deferred, unlike all other Rcheck_* subprograms, + -- itneeds to call Raise_Exception_No_Defer. -- This is consistent with Raise_From_Controlled_Operation diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index efe9b58d256..ec45c02e035 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -244,6 +244,55 @@ package body Exception_Data is Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); end Append_Info_Address; + --------------------------------------------- + -- Append_Info_Basic_Exception_Information -- + --------------------------------------------- + + -- To ease the maximum length computation, we define and pull out a couple + -- of string constants: + + BEI_Name_Header : constant String := "Exception name: "; + BEI_Msg_Header : constant String := "Message: "; + BEI_PID_Header : constant String := "PID: "; + + procedure Append_Info_Basic_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + Name : String (1 .. Exception_Name_Length (X)); + -- Buffer in which to fetch the exception name, in order to check + -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. + + Name_Ptr : Natural := Name'First - 1; + + begin + -- Output exception name and message except for _ABORT_SIGNAL, where + -- these two lines are omitted. + + Append_Info_Exception_Name (X, Name, Name_Ptr); + + if Name (Name'First) /= '_' then + Append_Info_String (BEI_Name_Header, Info, Ptr); + Append_Info_String (Name, Info, Ptr); + Append_Info_NL (Info, Ptr); + + if Exception_Message_Length (X) /= 0 then + Append_Info_String (BEI_Msg_Header, Info, Ptr); + Append_Info_Exception_Message (X, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end if; + + -- Output PID line if non-zero + + if X.Pid /= 0 then + Append_Info_String (BEI_PID_Header, Info, Ptr); + Append_Info_Nat (X.Pid, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end Append_Info_Basic_Exception_Information; + --------------------------- -- Append_Info_Character -- --------------------------- @@ -262,6 +311,72 @@ package body Exception_Data is end if; end Append_Info_Character; + ----------------------------------- + -- Append_Info_Exception_Message -- + ----------------------------------- + + procedure Append_Info_Exception_Message + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Message_Length (X); + Msg : constant String (1 .. Len) := X.Msg (1 .. Len); + begin + Append_Info_String (Msg, Info, Ptr); + end; + end Append_Info_Exception_Message; + + -------------------------------- + -- Append_Info_Exception_Name -- + -------------------------------- + + procedure Append_Info_Exception_Name + (Id : Exception_Id; + Info : in out String; + Ptr : in out Natural) + is + begin + if Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Name_Length (Id); + Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); + begin + Append_Info_String (Name, Info, Ptr); + end; + end Append_Info_Exception_Name; + + procedure Append_Info_Exception_Name + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + Append_Info_Exception_Name (X.Id, Info, Ptr); + end Append_Info_Exception_Name; + + ------------------------------ + -- Exception_Info_Maxlength -- + ------------------------------ + + function Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural + is + begin + return + Basic_Exception_Info_Maxlength (X) + + Untailored_Exception_Traceback_Maxlength (X); + end Exception_Info_Maxlength; + --------------------- -- Append_Info_Nat -- --------------------- @@ -315,67 +430,19 @@ package body Exception_Data is end if; end Append_Info_String; - --------------------------------------------- - -- Append_Info_Basic_Exception_Information -- - --------------------------------------------- - - -- To ease the maximum length computation, we define and pull out a couple - -- of string constants: - - BEI_Name_Header : constant String := "Exception name: "; - BEI_Msg_Header : constant String := "Message: "; - BEI_PID_Header : constant String := "PID: "; + -------------------------------------------------- + -- Append_Info_Untailored_Exception_Information -- + -------------------------------------------------- - procedure Append_Info_Basic_Exception_Information + procedure Append_Info_Untailored_Exception_Information (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural) is - Name : String (1 .. Exception_Name_Length (X)); - -- Buffer in which to fetch the exception name, in order to check - -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. - - Name_Ptr : Natural := Name'First - 1; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted. - - Append_Info_Exception_Name (X, Name, Name_Ptr); - - if Name (Name'First) /= '_' then - Append_Info_String (BEI_Name_Header, Info, Ptr); - Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); - - if Exception_Message_Length (X) /= 0 then - Append_Info_String (BEI_Msg_Header, Info, Ptr); - Append_Info_Exception_Message (X, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end if; - - -- Output PID line if non-zero - - if X.Pid /= 0 then - Append_Info_String (BEI_PID_Header, Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end Append_Info_Basic_Exception_Information; - - ------------------------------------------- - -- Basic_Exception_Information_Maxlength -- - ------------------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural is begin - return - BEI_Name_Header'Length + Exception_Name_Length (X) + 1 - + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 - + BEI_PID_Header'Length + 15; - end Basic_Exception_Info_Maxlength; + Append_Info_Basic_Exception_Information (X, Info, Ptr); + Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); + end Append_Info_Untailored_Exception_Information; ------------------------------------------------ -- Append_Info_Untailored_Exception_Traceback -- @@ -409,6 +476,7 @@ package body Exception_Data is end if; -- The traceback lines + Append_Info_String (BETB_Header, Info, Ptr); Append_Info_NL (Info, Ptr); @@ -421,108 +489,56 @@ package body Exception_Data is Append_Info_NL (Info, Ptr); end Append_Info_Untailored_Exception_Traceback; - ---------------------------------------------- - -- Untailored_Exception_Traceback_Maxlength -- - ---------------------------------------------- + ------------------------------------------- + -- Basic_Exception_Information_Maxlength -- + ------------------------------------------- - function Untailored_Exception_Traceback_Maxlength + function Basic_Exception_Info_Maxlength (X : Exception_Occurrence) return Natural is - Space_Per_Address : constant := 2 + 16 + 1; - -- Space for "0x" + HHHHHHHHHHHHHHHH + " " begin return - LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + - X.Num_Tracebacks * Space_Per_Address + 1; - end Untailored_Exception_Traceback_Maxlength; + BEI_Name_Header'Length + Exception_Name_Length (X) + 1 + + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 + + BEI_PID_Header'Length + 15; + end Basic_Exception_Info_Maxlength; - -------------------------------------------------- - -- Append_Info_Untailored_Exception_Information -- - -------------------------------------------------- + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + -- The tailored exception information is the basic information + -- associated with the tailored call chain backtrace. + + Tback_Info : constant String := Tailored_Exception_Traceback (X); + Tback_Len : constant Natural := Tback_Info'Length; + + Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); + Ptr : Natural := Info'First - 1; - 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_Untailored_Exception_Traceback (X, Info, Ptr); - end Append_Info_Untailored_Exception_Information; + Append_Info_String (Tback_Info, Info, Ptr); + return Info (Info'First .. Ptr); + end Exception_Information; ------------------------------ - -- Exception_Info_Maxlength -- + -- Exception_Message_Length -- ------------------------------ - function Exception_Info_Maxlength + function Exception_Message_Length (X : Exception_Occurrence) return Natural is begin - return - Basic_Exception_Info_Maxlength (X) - + Untailored_Exception_Traceback_Maxlength (X); - end Exception_Info_Maxlength; - - ----------------------------------- - -- Append_Info_Exception_Message -- - ----------------------------------- - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - if X.Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Message_Length (X); - Msg : constant String (1 .. Len) := X.Msg (1 .. Len); - begin - Append_Info_String (Msg, Info, Ptr); - end; - end Append_Info_Exception_Message; - - -------------------------------- - -- Append_Info_Exception_Name -- - -------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural) - is - begin - if Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Name_Length (Id); - Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); - begin - Append_Info_String (Name, Info, Ptr); - end; - end Append_Info_Exception_Name; - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Exception_Name (X.Id, Info, Ptr); - end Append_Info_Exception_Name; + return X.Msg_Length; + end Exception_Message_Length; --------------------------- -- Exception_Name_Length -- --------------------------- - function Exception_Name_Length - (Id : Exception_Id) return Natural - is + function Exception_Name_Length (Id : Exception_Id) return Natural is begin -- What is stored in the internal Name buffer includes a terminating -- null character that we never care about. @@ -530,23 +546,11 @@ package body Exception_Data is return Id.Name_Length - 1; end Exception_Name_Length; - function Exception_Name_Length - (X : Exception_Occurrence) return Natural is + function Exception_Name_Length (X : Exception_Occurrence) return Natural is begin return Exception_Name_Length (X.Id); end Exception_Name_Length; - ------------------------------ - -- Exception_Message_Length -- - ------------------------------ - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural - is - begin - return X.Msg_Length; - end Exception_Message_Length; - ------------------------------- -- Untailored_Exception_Traceback -- ------------------------------- @@ -681,8 +685,8 @@ package body Exception_Data is Id : Exception_Id; Message : String) is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); + Len : constant Natural := + Natural'Min (Message'Length, Exception_Msg_Max_Length); First : constant Integer := Message'First; begin Excep.Exception_Raised := False; @@ -712,7 +716,7 @@ package body Exception_Data is -- call become inoffensive. Wrapper : constant Traceback_Decorator_Wrapper_Call := - Traceback_Decorator_Wrapper; + Traceback_Decorator_Wrapper; begin if Wrapper = null then @@ -722,26 +726,19 @@ package body Exception_Data is end if; end Tailored_Exception_Traceback; - --------------------------- - -- Exception_Information -- - --------------------------- + ---------------------------------------------- + -- Untailored_Exception_Traceback_Maxlength -- + ---------------------------------------------- - function Exception_Information - (X : Exception_Occurrence) return String + function Untailored_Exception_Traceback_Maxlength + (X : Exception_Occurrence) return Natural is - -- The tailored exception information is the basic information - -- associated with the tailored call chain backtrace. - - Tback_Info : constant String := Tailored_Exception_Traceback (X); - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); - Ptr : Natural := Info'First - 1; - + Space_Per_Address : constant := 2 + 16 + 1; + -- Space for "0x" + HHHHHHHHHHHHHHHH + " " begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - return Info (Info'First .. Ptr); - end Exception_Information; + return + LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + + X.Num_Tracebacks * Space_Per_Address + 1; + end Untailored_Exception_Traceback_Maxlength; end Exception_Data; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 4de06a4d05a..c117319dbff 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4705,6 +4705,7 @@ package body Checks is else OK := False; end if; + return; end if; @@ -5100,7 +5101,7 @@ package body Checks is --------------------------- procedure Enable_Overflow_Check (N : Node_Id) is - Typ : constant Entity_Id := Base_Type (Etype (N)); + Typ : constant Entity_Id := Base_Type (Etype (N)); Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; Chk : Nat; OK : Boolean; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d19ca28bfac..b6602503f43 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5361,8 +5361,8 @@ package body Exp_Aggr is Make_Assignment_Statement (Loc, Name => Target, Expression => New_Copy (N))); - else + else Aggr_Code := Build_Array_Aggr_Code (N, Ctype => Ctyp, |