+2014-07-30 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * 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 <duff@adacore.com>
* g-exctra.adb, g-exctra.ads, s-exctra.adb, s-exctra.ads, Makefile.rtl,
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
-with Ada.Finalization;
+private with Ada.Finalization;
generic
type Element_Type is private;
-- --
-- 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- --
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 --
-------------
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 --
----------
(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
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;
-------------
-- --
-- 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 --
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;
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
projects / gcc.git / commitdiff