From: Arnaud Charlet Date: Wed, 30 Jul 2014 14:14:11 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=29ad9ea52944cd89ea5414c034d468f0862b6c18;p=gcc.git [multiple changes] 2014-07-30 Ed Schonberg * a-coorse.adb, a-coorse.ads (Generic_Keys): Add a Reference_Control_Type to generic package, to keep additional information for Reference_Types that manipulate keys. Add Adjust and Finalize procedures for this type. (Finalize): When finalizing a reference_preserving_key, verify that the key of the new value is equivalent to the key of the original element, raise Program_Error otherwise. (Insert): Detect tampering. (Reference_Preserving_Key): Build proper Reference_Control_Type, and update Busy and Lock bits to detect tampering. * a-cohase.ads: Keep with-clause private. 2014-07-30 Hristian Kirtchev * exp_ch4.adb (Expand_N_Op_Eq): Emit a warning when the operands of an equality are of an Unchecked_Union type and lack inferable discriminants. From-SVN: r213277 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d216f82fccb..fba9ada2d47 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2014-07-30 Ed Schonberg + + * a-coorse.adb, a-coorse.ads (Generic_Keys): Add a + Reference_Control_Type to generic package, to keep additional + information for Reference_Types that manipulate keys. Add Adjust and + Finalize procedures for this type. + (Finalize): When finalizing a reference_preserving_key, verify + that the key of the new value is equivalent to the key of the + original element, raise Program_Error otherwise. + (Insert): Detect tampering. + (Reference_Preserving_Key): Build proper Reference_Control_Type, + and update Busy and Lock bits to detect tampering. + * a-cohase.ads: Keep with-clause private. + +2014-07-30 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Op_Eq): Emit a warning when the operands + of an equality are of an Unchecked_Union type and lack inferable + discriminants. + 2014-07-30 Bob Duff * g-exctra.adb, g-exctra.ads, s-exctra.adb, s-exctra.ads, Makefile.rtl, diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 9e40f0e06b8..cfe048aa56a 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -35,7 +35,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Streams; -with Ada.Finalization; +private with Ada.Finalization; generic type Element_Type is private; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 675b40fcc39..116305bbf25 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.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- -- @@ -690,6 +690,24 @@ package body Ada.Containers.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 + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------- -- Ceiling -- ------------- @@ -793,6 +811,32 @@ package body Ada.Containers.Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.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; + Control.Old_Key := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -890,11 +934,24 @@ package body Ada.Containers.Ordered_Sets is (Vet (Container.Tree, 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 + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; - return (Element => Position.Node.Element'Access); + begin + return R : constant Reference_Type := + (Element => Position.Node.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 @@ -908,11 +965,24 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error with "key not in set"; end if; - -- 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 + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; - return (Element => Node.Element'Access); + begin + return R : constant Reference_Type := + (Element => Node.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-coorse.ads b/gcc/ada/a-coorse.ads index cf0110c74c2..eea99f1c411 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.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 -- @@ -278,8 +278,30 @@ package Ada.Containers.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; + + 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; use Ada.Streams; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 72e47d808f9..b3d180ff4d7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7357,12 +7357,25 @@ package body Exp_Ch4 is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); + -- Emit a warning on source equalities only, otherwise the + -- message may appear out of place due to internal use. The + -- warning is unconditional because it is required by the + -- language. + + if Comes_From_Source (N) then + Error_Msg_N + ("??Unchecked_Union discriminants cannot be determined", + N); + Error_Msg_N + ("\Program_Error will be raised for equality operation", + N); + end if; + -- Prevent Gigi from generating incorrect code by rewriting -- the equality as a standard False (documented where???). Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; -- If a type support function is present (for complex cases), use it