From aef44df1e36033fcaffa13cc546760b2cf1e1956 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Nov 2015 14:28:05 +0100 Subject: [PATCH] [multiple changes] 2015-11-12 Philippe Gil * g-debpoo.adb (Print_Address): print address in hexadecimal as in previous GNAT version (without secondary stack use) (Deallocate): Deallocate calling once Unlock_Task.all when it raise exception. 2015-11-12 Ed Schonberg * sem_ch3.adb (Analyze_Subtype_Declaration): Remove redundant copying of dimensions from parent type to subtype. This is properly done in Analyze_Dimension. * sem_dim.adb (Analyze_Dimension_Subtype_Declaration): Add entity to error message, so that reference to entity can be formatted properly. * opt.ads: Fix typo. From-SVN: r230254 --- gcc/ada/ChangeLog | 17 +++++++++++++++++ gcc/ada/g-debpoo.adb | 37 +++++++++++++++++++++++++++++++++++-- gcc/ada/opt.ads | 4 ++-- gcc/ada/sem_ch3.adb | 4 +++- gcc/ada/sem_dim.adb | 4 ++-- 5 files changed, 59 insertions(+), 7 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 98764271489..de1a91da2fe 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2015-11-12 Philippe Gil + + * g-debpoo.adb (Print_Address): print address in hexadecimal as + in previous GNAT version (without secondary stack use) + (Deallocate): Deallocate calling once Unlock_Task.all when it + raise exception. + +2015-11-12 Ed Schonberg + + * sem_ch3.adb (Analyze_Subtype_Declaration): Remove redundant + copying of dimensions from parent type to subtype. This is + properly done in Analyze_Dimension. + * sem_dim.adb (Analyze_Dimension_Subtype_Declaration): Add entity + to error message, so that reference to entity can be formatted + properly. + * opt.ads: Fix typo. + 2015-11-12 Bob Duff * impunit.adb, lib-xref.ads, restrict.ads, scos.ads, sem_attr.ads, diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index d51ae903c2b..98243fd76c4 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -482,8 +482,34 @@ package body GNAT.Debug_Pools is type My_Address is mod Memory_Size; function To_My_Address is new Ada.Unchecked_Conversion (System.Address, My_Address); + Address_To_Print : My_Address := To_My_Address (Addr); + type Hexadecimal_Element is range 0 .. 15; + Hexadecimal_Characters : constant array + (Hexadecimal_Element) of Character := + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); + pragma Warnings + (Off, "types for unchecked conversion have different sizes"); + function To_Hexadecimal_Element is new Ada.Unchecked_Conversion + (My_Address, Hexadecimal_Element); + pragma Warnings + (On, "types for unchecked conversion have different sizes"); + Number_Of_Hexadecimal_Characters_In_Address : constant Natural := + Standard'Address_Size / 4; + type Hexadecimal_Elements_Range is + range 1 .. Number_Of_Hexadecimal_Characters_In_Address; + Hexadecimal_Elements : array (Hexadecimal_Elements_Range) of + Hexadecimal_Element; begin - Put (File, My_Address'Image (To_My_Address (Addr))); + for Index in Hexadecimal_Elements_Range loop + Hexadecimal_Elements (Index) := + To_Hexadecimal_Element (Address_To_Print mod 16); + Address_To_Print := Address_To_Print / 16; + end loop; + Put (File, "0x"); + for Index in reverse Hexadecimal_Elements_Range loop + Put (File, Hexadecimal_Characters (Hexadecimal_Elements (Index))); + end loop; end Print_Address; -------------- @@ -1406,6 +1432,7 @@ package body GNAT.Debug_Pools is is pragma Unreferenced (Alignment); + Unlock_Task_Required : Boolean := False; Header : constant Allocation_Header_Access := Header_Of (Storage_Address); Valid : Boolean; @@ -1414,9 +1441,11 @@ package body GNAT.Debug_Pools is begin <> Lock_Task.all; + Unlock_Task_Required := True; Valid := Is_Valid (Storage_Address); if not Valid then + Unlock_Task_Required := False; Unlock_Task.all; if Storage_Address = System.Null_Address then @@ -1453,6 +1482,7 @@ package body GNAT.Debug_Pools is end if; elsif Header.Block_Size < 0 then + Unlock_Task_Required := False; Unlock_Task.all; if Pool.Raise_Exceptions then raise Freeing_Deallocated_Storage; @@ -1574,12 +1604,15 @@ package body GNAT.Debug_Pools is -- Do not physically release the memory here, but in Alloc. -- See comment there for details. + Unlock_Task_Required := False; Unlock_Task.all; end if; exception when others => - Unlock_Task.all; + if Unlock_Task_Required then + Unlock_Task.all; + end if; raise; end Deallocate; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9e0acdc317e..f9e45540ea6 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1376,7 +1376,7 @@ package Opt is Style_Check_Main : Boolean := False; -- GNAT -- Set True if Style_Check was set for the main unit. This is used to - -- renable style checks for units in the mail extended source that get + -- enable style checks for units in the main extended source that get -- with'ed indirectly. It is set True by use of either the -gnatg or -- -gnaty switches, but not by use of the Style_Checks pragma. @@ -2058,7 +2058,7 @@ package Opt is -- unit. This affects setting of the assert/debug pragma switches, which -- are normally set false by default for an internal unit, except when the -- internal unit is the main unit, in which case we use the command line - -- settings). + -- settings. procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type); -- This procedure restores a set of switch values previously saved by a diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 31f6bd2a1f7..26ed179296f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4833,7 +4833,9 @@ package body Sem_Ch3 is Set_Scalar_Range (Id, Scalar_Range (T)); Set_Digits_Value (Id, Digits_Value (T)); Set_Is_Constrained (Id, Is_Constrained (T)); - Copy_Dimensions (From => T, To => Id); + + -- If the floating point type has dimensions, these will be + -- inherited subsequently when Analyze_Dimensions is called. when Signed_Integer_Kind => Set_Ekind (Id, E_Signed_Integer_Subtype); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index b859b14af74..50676987367 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -2227,8 +2227,8 @@ package body Sem_Dim is -- it cannot inherit a dimension from its subtype. if Exists (Dims_Of_Id) then - Error_Msg_N - ("subtype& already" & Dimensions_Msg_Of (Id, True), N); + Error_Msg_NE + ("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id); else Set_Dimensions (Id, Dims_Of_Etyp); Set_Symbol (Id, Symbol_Of (Etyp)); -- 2.30.2