From 2e57f88b778de597f3bd3ed2fbe2b634eb46fc2d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 11 Jun 2014 12:52:35 +0200 Subject: [PATCH] [multiple changes] 2014-06-11 Geert Bosch * s-exctab.adb: avoid race conditions in exception registration. 2014-06-11 Robert Dewar * errout.adb (Warn_Insertion): New function. (Error_Msg): Use Warn_Insertion and Prescan_Message. (Error_Msg_Internal): Set Info field of error object. (Error_Msg_NEL): Use Prescan_Message. (Set_Msg_Text): Don't store info: at start of message. (Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning. (Skip_Msg_Insertion_Warning): Now just skips warning insertion. * errout.ads: Document new ?$? and >$> insertion sequences Document use of "(style)" and "info: " * erroutc.adb (dmsg): Print several missing fields (Get_Warning_Tag): Handle -gnatel case (?$?) (Output_Msg_Text): Deal with new tagging of info messages * erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object): Add field Info (Prescan_Message): New procedure, this procedure replaces the old Test_Style_Warning_Serious_Unconditional_Msg * errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb, sem_elab.adb: Follow new rules for info message (info belongs only at the start of a message, and only in the first message, not in any of the continuations). * gnat_ugn.texi: Document full set of warning tags. From-SVN: r211447 --- gcc/ada/ChangeLog | 27 ++++ gcc/ada/errout.adb | 99 +++++++++---- gcc/ada/errout.ads | 38 +++-- gcc/ada/erroutc.adb | 172 +++++++++++++--------- gcc/ada/erroutc.ads | 88 +++++++----- gcc/ada/errutil.adb | 5 +- gcc/ada/exp_util.adb | 6 +- gcc/ada/gnat_ugn.texi | 43 ++++-- gcc/ada/par-ch7.adb | 4 +- gcc/ada/s-exctab.adb | 328 +++++++++++++++++++++++++++--------------- gcc/ada/sem_ch13.adb | 6 +- gcc/ada/sem_ch7.adb | 11 +- gcc/ada/sem_elab.adb | 55 ++++--- 13 files changed, 586 insertions(+), 296 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0a404e082c4..a2ce54e9b0f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2014-06-11 Geert Bosch + + * s-exctab.adb: avoid race conditions in exception registration. + +2014-06-11 Robert Dewar + + * errout.adb (Warn_Insertion): New function. + (Error_Msg): Use Warn_Insertion and Prescan_Message. + (Error_Msg_Internal): Set Info field of error object. + (Error_Msg_NEL): Use Prescan_Message. + (Set_Msg_Text): Don't store info: at start of message. + (Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning. + (Skip_Msg_Insertion_Warning): Now just skips warning insertion. + * errout.ads: Document new ?$? and >$> insertion sequences + Document use of "(style)" and "info: " + * erroutc.adb (dmsg): Print several missing fields + (Get_Warning_Tag): Handle -gnatel case (?$?) (Output_Msg_Text): + Deal with new tagging of info messages + * erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object): + Add field Info (Prescan_Message): New procedure, this procedure + replaces the old Test_Style_Warning_Serious_Unconditional_Msg + * errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb, + sem_elab.adb: Follow new rules for info message (info belongs + only at the start of a message, and only in the first message, + not in any of the continuations). + * gnat_ugn.texi: Document full set of warning tags. + 2014-06-11 Gary Dismukes * sem_util.adb: Minor typo fix. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 37a1b64d686..7f02fe22571 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -197,6 +197,17 @@ package body Errout is -- spec for precise definition of the conversion that is performed by this -- routine in OpenVMS mode. + function Warn_Insertion return String; + -- This is called for warning messages only (so Warning_Msg_Char is set) + -- and returns a corresponding string to use at the beginning of generated + -- auxiliary messages, such as "in instantiation at ...". + -- 'a' .. 'z' returns "?x?" + -- 'A' .. 'Z' returns "?X?" + -- '*' returns "?*?" + -- '$' returns "?$?info: " + -- ' ' returns " " + -- No other settings are valid + ----------------------- -- Change_Error_Text -- ----------------------- @@ -282,7 +293,7 @@ package body Errout is -- Start of processing for new message Sindex := Get_Source_File_Index (Flag_Location); - Test_Style_Warning_Serious_Unconditional_Msg (Msg); + Prescan_Message (Msg); Orig_Loc := Original_Location (Flag_Location); -- If the current location is in an instantiation, the issue arises of @@ -332,8 +343,7 @@ package body Errout is -- that style checks are not considered warning messages for this -- purpose. - if Is_Warning_Msg - and then Warnings_Suppressed (Orig_Loc) /= No_String + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String then return; @@ -438,9 +448,9 @@ package body Errout is -- Case of inlined body if Inlined_Body (X) then - if Is_Warning_Msg or else Is_Style_Msg then + if Is_Warning_Msg or Is_Style_Msg then Error_Msg_Internal - ("?in inlined body #", + (Warn_Insertion & "in inlined body #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); else Error_Msg_Internal @@ -453,7 +463,7 @@ package body Errout is else if Is_Warning_Msg or else Is_Style_Msg then Error_Msg_Internal - ("?in instantiation #", + (Warn_Insertion & "in instantiation #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); else Error_Msg_Internal @@ -732,7 +742,6 @@ package body Errout is Continuation_New_Line := False; Suppress_Message := False; Kill_Message := False; - Warning_Msg_Char := ' '; Set_Msg_Text (Msg, Sptr); -- Kill continuation if parent message killed @@ -944,6 +953,7 @@ package body Errout is Line => Get_Physical_Line_Number (Sptr), Col => Get_Column_Number (Sptr), Warn => Is_Warning_Msg, + Info => Is_Info_Msg, Warn_Err => False, -- reset below Warn_Chr => Warning_Msg_Char, Style => Is_Style_Msg, @@ -1159,7 +1169,7 @@ package body Errout is return; end if; - Test_Style_Warning_Serious_Unconditional_Msg (Msg); + Prescan_Message (Msg); -- Special handling for warning messages @@ -2745,19 +2755,21 @@ package body Errout is C : Character; -- Current character P : Natural; -- Current index; - procedure Set_Msg_Insertion_Warning (C : Character); - -- Deal with ? ?? ?x? ?X? insertion sequences (also < << 6 + and then Text (Text'First .. Text'First + 5) = "info: " + then + P := Text'First + 6; + else + P := Text'First; + end if; + + -- Loop through characters of message + while P <= Text'Last loop C := Text (P); P := P + 1; @@ -2846,16 +2871,10 @@ package body Errout is null; -- already dealt with when '?' => - Set_Msg_Insertion_Warning ('?'); + Skip_Msg_Insertion_Warning ('?'); when '<' => - - -- Note: the prescan already set Is_Warning_Msg True if and - -- only if Error_Msg_Warn is set to True. If Error_Msg_Warn - -- is False, the call to Set_Msg_Insertion_Warning here does - -- no harm, since Warning_Msg_Char is ignored in that case. - - Set_Msg_Insertion_Warning ('<'); + Skip_Msg_Insertion_Warning ('<'); when '|' => null; -- already dealt with @@ -3233,4 +3252,22 @@ package body Errout is end loop; end VMS_Convert; + -------------------- + -- Warn_Insertion -- + -------------------- + + function Warn_Insertion return String is + begin + case Warning_Msg_Char is + when '?' => + return "??"; + when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' => + return '?' & Warning_Msg_Char & '?'; + when ' ' => + return "?"; + when others => + raise Program_Error; + end case; + end Warn_Insertion; + end Errout; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index a42d3dba75c..45234a4dc9b 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -60,12 +60,13 @@ package Errout is -- Exception raised if Raise_Exception_On_Error is true Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch; - -- If this is set True, then the ??/?*?/?x?/?X? sequences in error messages - -- generate appropriate tags for the output error messages. If this switch - -- is False, then these sequences are still recognized (for the purposes - -- of implementing pragmas Warnings (Off,..) and Warning_As_Pragma(...) but - -- do not result in adding the error message tag. The -gnatw.d switch sets - -- this flag True, -gnatw.D sets this flag False. + -- If this is set True, then the ??/?*?/?$?/?x?/?X? insertion sequences in + -- error messages generate appropriate tags for the output error messages. + -- If this switch is False, then these sequences are still recognized (for + -- the purposes of implementing the pattern matching in pragmas Warnings + -- (Off,..) and Warning_As_Pragma(...) but do not result in adding the + -- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D + -- sets this flag False. ----------------------------------- -- Suppression of Error Messages -- @@ -283,7 +284,7 @@ package Errout is -- messages, and the usual style is to include it, since it makes it -- clear that the continuation is part of a warning message. -- - -- Note: this usage is obsolete, use ?? ?*? ?x? ?X? instead to specify + -- Note: this usage is obsolete, use ?? ?*? ?$? ?x? ?X? to specify -- the string to be added when Warn_Doc_Switch is set to True. If this -- switch is True, then for simple ? messages it has no effect. This -- simple form is to ease transition and will be removed later. @@ -309,11 +310,17 @@ package Errout is -- "[restriction warning]" at the end of the warning message. For -- continuations, use this on each continuation message. + -- Insertion character ?$? (elaboration information messages) + -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- "[-gnatel]" at the end of the info message. This is used for the + -- messages generated by the switch -gnatel. For continuations, use + -- this on each continuation message. + -- Insertion character < (Less Than: conditional warning message) -- The character < appearing anywhere in a message is used for a -- conditional error message. If Error_Msg_Warn is True, then the - -- effect is the same as ? described above, and in particular << - -- = 6 - and then Txt (Txt'First .. Txt'First + 5) = "info: " - then - null; + if Errors.Table (E).Info then + Txt := new String'("info: " & Txt.all); -- Warning treated as error elsif Errors.Table (E).Warn_Err then - -- We prefix the tag error: rather than warning: and postfix + -- We prefix with "error:" rather than warning: and postfix -- [warning-as-error] at the end. Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; Txt := new String'("error: " & Txt.all & " [warning-as-error]"); - -- Normal case, prefix + -- Normal case, prefix with "warning: " else Txt := new String'("warning: " & Txt.all); @@ -683,6 +686,103 @@ package body Erroutc is end; end Output_Msg_Text; + --------------------- + -- Prescan_Message -- + --------------------- + + procedure Prescan_Message (Msg : String) is + J : Natural; + + begin + -- Nothing to do for continuation line + + if Msg (Msg'First) = '\' then + return; + end if; + + -- Set initial values of globals (may be changed during scan) + + Is_Serious_Error := True; + Is_Unconditional_Msg := False; + Is_Warning_Msg := False; + Has_Double_Exclam := False; + + -- Check style message + + Is_Style_Msg := + Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"; + + -- Check info message + + Is_Info_Msg := + Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: "; + + -- Loop through message looking for relevant insertion sequences + + J := Msg'First; + while J <= Msg'Last loop + + -- If we have a quote, don't look at following character + + if Msg (J) = ''' then + J := J + 2; + + -- Warning message (? or < insertion sequence) + + elsif Msg (J) = '?' or else Msg (J) = '<' then + Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn; + Warning_Msg_Char := ' '; + J := J + 1; + + if Is_Warning_Msg then + declare + C : constant Character := Msg (J - 1); + begin + if J <= Msg'Last then + if Msg (J) = C then + Warning_Msg_Char := '?'; + J := J + 1; + + elsif J < Msg'Last and then Msg (J + 1) = C + and then (Msg (J) in 'a' .. 'z' or else + Msg (J) in 'A' .. 'Z' or else + Msg (J) = '*' or else + Msg (J) = '$') + then + Warning_Msg_Char := Msg (J); + J := J + 2; + end if; + end if; + end; + end if; + + -- Unconditional message (! insertion) + + elsif Msg (J) = '!' then + Is_Unconditional_Msg := True; + J := J + 1; + + if J <= Msg'Last and then Msg (J) = '!' then + Has_Double_Exclam := True; + J := J + 1; + end if; + + -- Non-serious error (| insertion) + + elsif Msg (J) = '|' then + Is_Serious_Error := False; + J := J + 1; + + else + J := J + 1; + end if; + end loop; + + if Is_Warning_Msg or Is_Style_Msg then + Is_Serious_Error := False; + end if; + end Prescan_Message; + -------------------- -- Purge_Messages -- -------------------- @@ -1251,6 +1351,7 @@ package body Erroutc is for J in 1 .. Specific_Warnings.Last loop declare SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + begin if Msg = SWE.Msg.all and then Loc > SWE.Start @@ -1352,63 +1453,6 @@ package body Erroutc is end if; end Set_Warnings_Mode_On; - ------------------------------------ - -- Test_Style_Warning_Serious_Msg -- - ------------------------------------ - - procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is - begin - -- Nothing to do for continuation line - - if Msg (Msg'First) = '\' then - return; - end if; - - -- Set initial values of globals (may be changed during scan) - - Is_Serious_Error := True; - Is_Unconditional_Msg := False; - Is_Warning_Msg := False; - Has_Double_Exclam := False; - - Is_Style_Msg := - (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); - - for J in Msg'Range loop - if Msg (J) = '?' - and then (J = Msg'First or else Msg (J - 1) /= ''') - then - Is_Warning_Msg := True; - Warning_Msg_Char := ' '; - - elsif Msg (J) = '!' - and then (J = Msg'First or else Msg (J - 1) /= ''') - then - Is_Unconditional_Msg := True; - Warning_Msg_Char := ' '; - - if J < Msg'Last and then Msg (J + 1) = '!' then - Has_Double_Exclam := True; - end if; - - elsif Msg (J) = '<' - and then (J = Msg'First or else Msg (J - 1) /= ''') - then - Is_Warning_Msg := Error_Msg_Warn; - Warning_Msg_Char := ' '; - - elsif Msg (J) = '|' - and then (J = Msg'First or else Msg (J - 1) /= ''') - then - Is_Serious_Error := False; - end if; - end loop; - - if Is_Warning_Msg or Is_Style_Msg then - Is_Serious_Error := False; - end if; - end Test_Style_Warning_Serious_Unconditional_Msg; - -------------------------------- -- Validate_Specific_Warnings -- -------------------------------- diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index c638aac1b1e..f23f4df588f 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -60,15 +60,24 @@ package Erroutc is -- character ! and is thus to be treated as an unconditional message. Is_Warning_Msg : Boolean := False; - -- Set True to indicate if current message is warning message (contains ?) + -- Set True to indicate if current message is warning message (contains ? + -- or contains < and Error_Msg_Warn is True. + + Is_Info_Msg : Boolean := False; + -- Set True to indicate that the current message starts with the characters + -- "info: " and is to be treated as an information message. This string + -- will be prepended to the message and all its continuations. Warning_Msg_Char : Character; -- Warning character, valid only if Is_Warning_Msg is True - -- ' ' -- ? appeared on its own in message - -- '?' -- ?? appeared in message - -- 'x' -- ?x? appeared in message (x = a .. z) - -- 'X' -- ?X? appeared in message (X = A .. Z) - -- '*' -- ?*? appeared in message + -- ' ' -- ? or < appeared on its own in message + -- '?' -- ?? or << appeared in message + -- 'x' -- ?x? or Dummy_Node, To => Package_Node); end if; diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb index a94d99a4eba..23a48158092 100644 --- a/gcc/ada/s-exctab.adb +++ b/gcc/ada/s-exctab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -31,71 +31,167 @@ pragma Compiler_Unit_Warning; -with System.HTable; -with System.Soft_Links; use System.Soft_Links; +with System.Soft_Links; use System.Soft_Links; package body System.Exception_Table is use System.Standard_Library; - type HTable_Headers is range 1 .. 37; + type Hash_Val is mod 2 ** 8; + subtype Hash_Idx is Hash_Val range 1 .. 37; - procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr); - function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr; + HTable : array (Hash_Idx) of aliased Exception_Data_Ptr; + -- Actual hash table containing all registered exceptions + -- + -- The table is very small and the hash function weak, as looking up + -- registered exceptions is rare and minimizing space and time overhead + -- of registration is more important. In addition, it is expected that the + -- exceptions that need to be looked up are registered dynamically, and + -- therefore will be at the begin of the hash chains. + -- + -- The table differs from System.HTable.Static_HTable in that the final + -- element of each chain is not marked by null, but by a pointer to self. + -- This way it is possible to defend against the same entry being inserted + -- twice, without having to do a lookup which is relatively expensive for + -- programs with large number + -- + -- All non-local subprograms use the global Task_Lock to protect against + -- concurrent use of the exception table. This is needed as local + -- exceptions may be declared concurrently with those declared at the + -- library level. - function Hash (F : System.Address) return HTable_Headers; - function Equal (A, B : System.Address) return Boolean; - function Get_Key (T : Exception_Data_Ptr) return System.Address; + -- Local Subprograms - package Exception_HTable is new System.HTable.Static_HTable ( - Header_Num => HTable_Headers, - Element => Exception_Data, - Elmt_Ptr => Exception_Data_Ptr, - Null_Ptr => null, - Set_Next => Set_HT_Link, - Next => Get_HT_Link, - Key => System.Address, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); + generic + with procedure Process (T : Exception_Data_Ptr; More : out Boolean); + procedure Iterate; + -- Iterate over all - ----------- - -- Equal -- - ----------- + function Lookup (Name : String) return Exception_Data_Ptr; + -- Find and return the Exception_Data of the exception with the given Name + -- (which must be in all uppercase), or null if none was registered. + + procedure Register (Item : Exception_Data_Ptr); + -- Register an exception with the given Exception_Data in the table. + + function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean; + -- Return True iff Item.Full_Name and Name are equal. Both names are + -- assumed to be in all uppercase and end with ASCII.NUL. + + function Hash (S : String) return Hash_Idx; + -- Return the index in the hash table for S, which is assumed to be all + -- uppercase and end with ASCII.NUL. + + -------------- + -- Has_Name -- + -------------- + + function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean + is + S : constant Big_String_Ptr := To_Ptr (Item.Full_Name); + J : Integer := S'First; - function Equal (A, B : System.Address) return Boolean is - S1 : constant Big_String_Ptr := To_Ptr (A); - S2 : constant Big_String_Ptr := To_Ptr (B); - J : Integer := 1; begin - loop - if S1 (J) /= S2 (J) then + for K in Name'Range loop + + -- Note that as both items are terminated with ASCII.NUL, the + -- comparison below must fail for strings of different lengths. + + if S (J) /= Name (K) then return False; - elsif S1 (J) = ASCII.NUL then - return True; - else - J := J + 1; end if; + + J := J + 1; end loop; - end Equal; - ----------------- - -- Get_HT_Link -- - ----------------- + return True; + end Has_Name; + + ------------ + -- Lookup -- + ------------ + + function Lookup (Name : String) return Exception_Data_Ptr is + Prev : Exception_Data_Ptr; + Curr : Exception_Data_Ptr; - function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is begin - return T.HTable_Ptr; - end Get_HT_Link; + Curr := HTable (Hash (Name)); + Prev := null; + while Curr /= Prev loop + if Has_Name (Curr, Name) then + return Curr; + end if; + + Prev := Curr; + Curr := Curr.HTable_Ptr; + end loop; + + return null; + end Lookup; + + ---------- + -- Hash -- + ---------- + + function Hash (S : String) return Hash_Idx is + Hash : Hash_Val := 0; + + begin + for J in S'Range loop + exit when S (J) = ASCII.NUL; + Hash := Hash xor Character'Pos (S (J)); + end loop; + + return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1); + end Hash; ------------- - -- Get_Key -- + -- Iterate -- ------------- - function Get_Key (T : Exception_Data_Ptr) return System.Address is + procedure Iterate is + More : Boolean; + Prev, Curr : Exception_Data_Ptr; + begin - return T.Full_Name; - end Get_Key; + Outer : for Idx in HTable'Range loop + Prev := null; + Curr := HTable (Idx); + + while Curr /= Prev loop + Process (Curr, More); + + exit Outer when not More; + + Prev := Curr; + Curr := Curr.HTable_Ptr; + end loop; + end loop Outer; + end Iterate; + + -------------- + -- Register -- + -------------- + + procedure Register (Item : Exception_Data_Ptr) is + begin + if Item.HTable_Ptr = null then + Prepend_To_Chain : declare + Chain : Exception_Data_Ptr + renames HTable (Hash (To_Ptr (Item.Full_Name).all)); + + begin + if Chain = null then + Item.HTable_Ptr := Item; + else + Item.HTable_Ptr := Chain; + end if; + + Chain := Item; + end Prepend_To_Chain; + end if; + end Register; ------------------------------- -- Get_Registered_Exceptions -- @@ -105,45 +201,41 @@ package body System.Exception_Table is (List : out Exception_Data_Array; Last : out Integer) is - Data : Exception_Data_Ptr := Exception_HTable.Get_First; + procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean); + -- Add Item to List (List'First .. Last) by first incrementing Last + -- and storing Item in List (Last). Last should be in List'First - 1 + -- and List'Last. + + procedure Get_All is new Iterate (Get_One); + -- Store all registered exceptions in List, updating Last + + ------------- + -- Get_One -- + ------------- + + procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is + begin + if Last < List'Last then + Last := Last + 1; + List (Last) := Item; + More := True; + + else + More := False; + end if; + end Get_One; begin - Lock_Task.all; + -- In this routine the invariant is that List (List'First .. Last) + -- contains the registered exceptions retrieved so far. + Last := List'First - 1; - while Last < List'Last and then Data /= null loop - Last := Last + 1; - List (Last) := Data; - Data := Exception_HTable.Get_Next; - end loop; - + Lock_Task.all; + Get_All; Unlock_Task.all; end Get_Registered_Exceptions; - ---------- - -- Hash -- - ---------- - - function Hash (F : System.Address) return HTable_Headers is - type S is mod 2**8; - - Str : constant Big_String_Ptr := To_Ptr (F); - Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1); - Tmp : S := 0; - J : Positive; - - begin - J := 1; - loop - if Str (J) = ASCII.NUL then - return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size); - else - Tmp := Tmp xor S (Character'Pos (Str (J))); - end if; - J := J + 1; - end loop; - end Hash; - ------------------------ -- Internal_Exception -- ------------------------ @@ -152,25 +244,30 @@ package body System.Exception_Table is (X : String; Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr is + -- If X was not yet registered and Create_if_Not_Exist is True, + -- dynamically allocate and register a new exception. + type String_Ptr is access all String; - Copy : aliased String (X'First .. X'Last + 1); - Res : Exception_Data_Ptr; Dyn_Copy : String_Ptr; + Copy : aliased String (X'First .. X'Last + 1); + Result : Exception_Data_Ptr; begin + Lock_Task.all; + Copy (X'Range) := X; Copy (Copy'Last) := ASCII.NUL; - Res := Exception_HTable.Get (Copy'Address); + Result := Lookup (Copy); -- If unknown exception, create it on the heap. This is a legitimate - -- situation in the distributed case when an exception is defined only - -- in a partition + -- situation in the distributed case when an exception is defined + -- only in a partition - if Res = null and then Create_If_Not_Exist then + if Result = null and then Create_If_Not_Exist then Dyn_Copy := new String'(Copy); - Res := + Result := new Exception_Data' (Not_Handled_By_Others => False, Lang => 'A', @@ -180,10 +277,12 @@ package body System.Exception_Table is Foreign_Data => Null_Address, Raise_Hook => null); - Register_Exception (Res); + Register (Result); end if; - return Res; + Unlock_Task.all; + + return Result; end Internal_Exception; ------------------------ @@ -192,7 +291,9 @@ package body System.Exception_Table is procedure Register_Exception (X : Exception_Data_Ptr) is begin - Exception_HTable.Set (X); + Lock_Task.all; + Register (X); + Unlock_Task.all; end Register_Exception; --------------------------------- @@ -201,43 +302,38 @@ package body System.Exception_Table is function Registered_Exceptions_Count return Natural is Count : Natural := 0; - Data : Exception_Data_Ptr := Exception_HTable.Get_First; + + procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean); + -- Update Count for given Item + + procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is + pragma Unreferenced (Item); + begin + Count := Count + 1; + More := Count < Natural'Last; + end Count_Item; + + procedure Count_All is new Iterate (Count_Item); begin - -- We need to lock the runtime in the meantime, to avoid concurrent - -- access since we have only one iterator. - Lock_Task.all; - - while Data /= null loop - Count := Count + 1; - Data := Exception_HTable.Get_Next; - end loop; - + Count_All; Unlock_Task.all; + return Count; end Registered_Exceptions_Count; - ----------------- - -- Set_HT_Link -- - ----------------- - - procedure Set_HT_Link - (T : Exception_Data_Ptr; - Next : Exception_Data_Ptr) - is - begin - T.HTable_Ptr := Next; - end Set_HT_Link; - --- Register the standard exceptions at elaboration time - begin - Register_Exception (Abort_Signal_Def'Access); - Register_Exception (Tasking_Error_Def'Access); - Register_Exception (Storage_Error_Def'Access); - Register_Exception (Program_Error_Def'Access); - Register_Exception (Numeric_Error_Def'Access); - Register_Exception (Constraint_Error_Def'Access); + -- Register the standard exceptions at elaboration time + -- We don't need to use the locking version here as the elaboration + -- will not be concurrent and no tasks can call any subprograms of this + -- unit before it has been elaborated. + + Register (Abort_Signal_Def'Access); + Register (Tasking_Error_Def'Access); + Register (Storage_Error_Def'Access); + Register (Program_Error_Def'Access); + Register (Numeric_Error_Def'Access); + Register (Constraint_Error_Def'Access); end System.Exception_Table; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bf42b0eebc4..6417523335a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -661,12 +661,12 @@ package body Sem_Ch13 is if Bytes_Big_Endian then Error_Msg_NE - ("\info: big-endian range for " + ("\big-endian range for " & "component & is ^ .. ^?V?", First_Bit (CC), Comp); else Error_Msg_NE - ("\info: little-endian range " + ("\little-endian range " & "for component & is ^ .. ^?V?", First_Bit (CC), Comp); end if; @@ -6324,7 +6324,7 @@ package body Sem_Ch13 is if Inherit and Opt.List_Inherited_Aspects then Error_Msg_Sloc := Sloc (Ritem); Error_Msg_N - ("?L?info: & inherits `Invariant''Class` aspect from #", + ("info: & inherits `Invariant''Class` aspect from #?L?", Typ); end if; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 7afe23676c5..d9a9dab88ec 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2885,13 +2885,12 @@ package body Sem_Ch7 is -- Body required if library package with pragma Elaborate_Body elsif Has_Pragma_Elaborate_Body (P) then - Error_Msg_N - ("?Y?info: & requires body (Elaborate_Body)", P); + Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", P); -- Body required if subprogram elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then - Error_Msg_N ("?Y?info: & requires body (subprogram case)", P); + Error_Msg_N ("info: & requires body (subprogram case)?Y?", P); -- Body required if generic parent has Elaborate_Body @@ -2904,7 +2903,7 @@ package body Sem_Ch7 is begin if Has_Pragma_Elaborate_Body (G_P) then Error_Msg_N - ("?Y?info: & requires body (generic parent Elaborate_Body)", + ("info: & requires body (generic parent Elaborate_Body)?Y?", P); end if; end; @@ -2922,7 +2921,7 @@ package body Sem_Ch7 is not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) then Error_Msg_N - ("?Y?info: & requires body (non-null abstract state aspect)", P); + ("info: & requires body (non-null abstract state aspect)?Y?", P); end if; -- Otherwise search entity chain for entity requiring completion @@ -2985,7 +2984,7 @@ package body Sem_Ch7 is then Error_Msg_Node_2 := E; Error_Msg_NE - ("?Y?info: & requires body (& requires completion)", + ("info: & requires body (& requires completion)?Y?", E, P); -- Entity that does not require completion diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 7f494d85183..da327315730 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -942,7 +942,7 @@ package body Sem_Elab is if Inst_Case then Elab_Warning ("instantiation of& may raise Program_Error?l?", - "info: instantiation of& during elaboration?", Ent); + "info: instantiation of& during elaboration?$?", Ent); -- Indirect call case, info message only in static elaboration -- case, because the attribute reference itself cannot raise @@ -950,7 +950,7 @@ package body Sem_Elab is elsif Access_Case then Elab_Warning - ("", "info: access to& during elaboration?", Ent); + ("", "info: access to& during elaboration?$?", Ent); -- Subprogram call case @@ -961,13 +961,13 @@ package body Sem_Elab is then Elab_Warning ("implicit call to & may raise Program_Error?l?", - "info: implicit call to & during elaboration?", + "info: implicit call to & during elaboration?$?", Ent); else Elab_Warning ("call to & may raise Program_Error?l?", - "info: call to & during elaboration?", + "info: call to & during elaboration?$?", Ent); end if; end if; @@ -977,13 +977,13 @@ package body Sem_Elab is if Nkind (N) in N_Subprogram_Instantiation then Elab_Warning ("\missing pragma Elaborate for&?l?", - "\info: implicit pragma Elaborate for& generated?", + "\implicit pragma Elaborate for& generated?$?", W_Scope); else Elab_Warning ("\missing pragma Elaborate_All for&?l?", - "\info: implicit pragma Elaborate_All for & generated?", + "\implicit pragma Elaborate_All for & generated?$?", W_Scope); end if; end Generate_Elab_Warnings; @@ -1063,7 +1063,7 @@ package body Sem_Elab is Error_Msg_Node_2 := W_Scope; Error_Msg_NE ("info: call to& in elaboration code " & - "requires pragma Elaborate_All on&?", N, E); + "requires pragma Elaborate_All on&?$?", N, E); end if; -- Set indication for binder to generate Elaborate_All @@ -2320,15 +2320,14 @@ package body Sem_Elab is if Inst_Case then Error_Msg_NE - ("instantiation of& may occur before body is seen<<", + ("instantiation of& may occur before body is seen