OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r213277
This commit is contained in:
Arnaud Charlet 2014-07-30 16:14:11 +02:00
parent 995683a614
commit 29ad9ea529
5 changed files with 139 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/ChangeLog
View File

@ -1,3 +1,23 @@
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,

2
gcc/ada/a-cohase.ads
View File

@ -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;

88
gcc/ada/a-coorse.adb
View File

@ -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;
-------------

28
gcc/ada/a-coorse.ads
View File

@ -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;

15
gcc/ada/exp_ch4.adb
View File

@ -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