From 17d7aa85b71369de1a340db1f28575316703032b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 12:18:12 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Bob Duff * exp_intr.adb (Add_Source_Info): Do not decode file names; they were not encoded in the first place. 2017-09-08 Bob Duff * a-tags.adb (Internal_Tag): Unsuppress checks, so we get exceptions instead of crashes. Check for absurdly long strings and empty strings. Empty strings cause trouble because they can have super-null ranges (e.g. 100..10), which causes Ext_Copy to be empty, which causes an array index out of bounds. * s-ststop.adb (Input): Unsuppress checks, so we get exceptions instead of crashes. 2017-09-08 Arnaud Charlet * sem_util.adb (Is_CCT_Instance): allow use in the context of protected types. 2017-09-08 Arnaud Charlet * a-tigeli.adb: minor remove extra whitespace. From-SVN: r251885 --- gcc/ada/ChangeLog | 24 ++++++++++++++++++++++++ gcc/ada/a-tags.adb | 27 ++++++++++++++++++++++----- gcc/ada/a-tigeli.adb | 4 ++-- gcc/ada/exp_intr.adb | 2 +- gcc/ada/s-ststop.adb | 13 ++++++++----- gcc/ada/sem_util.adb | 1 + 6 files changed, 58 insertions(+), 13 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 52e46c63d2e..16102b40580 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2017-09-08 Bob Duff + + * exp_intr.adb (Add_Source_Info): Do not decode + file names; they were not encoded in the first place. + +2017-09-08 Bob Duff + + * a-tags.adb (Internal_Tag): Unsuppress checks, so we get + exceptions instead of crashes. Check for absurdly long strings + and empty strings. Empty strings cause trouble because they can + have super-null ranges (e.g. 100..10), which causes Ext_Copy to + be empty, which causes an array index out of bounds. + * s-ststop.adb (Input): Unsuppress checks, so we get exceptions + instead of crashes. + +2017-09-08 Arnaud Charlet + + * sem_util.adb (Is_CCT_Instance): allow use in + the context of protected types. + +2017-09-08 Arnaud Charlet + + * a-tigeli.adb: minor remove extra whitespace. + 2017-09-08 Gary Dismukes * par-ch4.adb: Reformatting of an error message. diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index b15c990a03b..72ec05d5453 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -641,10 +641,22 @@ package body Ada.Tags is Header_Separator : constant Character := '#'; function Internal_Tag (External : String) return Tag is - Ext_Copy : aliased String (External'First .. External'Last + 1); - Res : Tag := null; + pragma Unsuppress (All_Checks); + -- To make T'Class'Input robust in the case of bad data + + Res : Tag := null; begin + -- Raise Tag_Error for empty strings, and for absurdly long strings. + -- This is to make T'Class'Input robust in the case of bad data, for + -- example a String(123456789..1234). The limit of 10,000 characters is + -- arbitrary, but is unlikely to be exceeded by legitimate external tag + -- names. + + if External'Length not in 1 .. 10_000 then + raise Tag_Error; + end if; + -- Handle locally defined tagged types if External'Length > Internal_Tag_Header'Length @@ -731,9 +743,14 @@ package body Ada.Tags is else -- Make NUL-terminated copy of external tag string - Ext_Copy (External'Range) := External; - Ext_Copy (Ext_Copy'Last) := ASCII.NUL; - Res := External_Tag_HTable.Get (Ext_Copy'Address); + declare + Ext_Copy : aliased String (External'First .. External'Last + 1); + pragma Assert (Ext_Copy'Length > 1); -- See Length check at top + begin + Ext_Copy (External'Range) := External; + Ext_Copy (Ext_Copy'Last) := ASCII.NUL; + Res := External_Tag_HTable.Get (Ext_Copy'Address); + end; end if; if Res = null then diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb index f7cb5332752..77b2179bc74 100644 --- a/gcc/ada/a-tigeli.adb +++ b/gcc/ada/a-tigeli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -197,7 +197,7 @@ begin -- last line, in which case no End_Error should be raised. if ch = EOF then - if Last < Item'First then + if Last < Item'First then raise End_Error; else -- All done diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 1d3a321604a..6de8952ae85 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -125,7 +125,7 @@ package body Exp_Intr is Append (Buf, Nat (Get_Logical_Line_Number (Loc))); when Name_File => - Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc))); + Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); when Name_Source_Location => Build_Location_String (Buf, Loc); diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb index 612ed0c8ac1..1b8ad9696d0 100644 --- a/gcc/ada/s-ststop.adb +++ b/gcc/ada/s-ststop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2017, 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,17 +128,20 @@ package body System.Strings.Stream_Ops is (Strm : access Root_Stream_Type'Class; IO : IO_Kind) return Array_Type is + pragma Unsuppress (All_Checks); + -- To make T'Class'Input robust in the case of bad data. The + -- declaration of Item below could raise Storage_Error if the length + -- is huge. begin if Strm = null then raise Constraint_Error; end if; declare - Low : Index_Type; - High : Index_Type; - + Low, High : Index_Type'Base; begin - -- Read the bounds of the string + -- Read the bounds of the string. Note that they could be out of + -- range of Index_Type in the case of empty arrays. Index_Type'Read (Strm, Low); Index_Type'Read (Strm, High); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5e74d20c093..48b8432096e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12499,6 +12499,7 @@ package body Sem_Util is E_Function, E_Package, E_Procedure, + E_Protected_Type, E_Task_Type)); return Scope_Within_Or_Same (Context_Id, Ref_Id); -- 2.30.2