[multiple changes]
2014-07-30 Robert Dewar <dewar@adacore.com> * clean.adb: Minor reformatting. * opt.ads: Minor fix to incorrect comment. 2014-07-30 Ed Schonberg <schonberg@adacore.com> * a-chtgbo.ads, a-chtgbo.adb (Delete_Node_At_Index): New subprogram, used by bounded hashed sets, to delete a node at a given index, whose element may have been improperly updated through a Reference_Preserving key. * a-cbhase.ads: Add Reference_Control_Type to package Generic_Keys. * a-cbhase.adb: Add Adjust and Finalize routines for Reference_Control_Type. (Delete, Insert): Raise Program_Error, not Constraint_Error, when operation is illegal. (Reference_Preserving_Key): Build aggregate for Reference_Control_Type * a-cmbutr.ads: Add Reference_Control_Type to detect tampering. Add private with_clause for Ada.Finalization. * a-cbmutr.adb: Add Adjust and Finalize routines for Reference_Control_Type. Use it in the construction of Reference and Constant_Reference values. From-SVN: r213285
This commit is contained in:
parent
c98b825308
commit
2b4c962d78
|
@ -1,3 +1,26 @@
|
||||||
|
2014-07-30 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* clean.adb: Minor reformatting.
|
||||||
|
* opt.ads: Minor fix to incorrect comment.
|
||||||
|
|
||||||
|
2014-07-30 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* a-chtgbo.ads, a-chtgbo.adb (Delete_Node_At_Index): New
|
||||||
|
subprogram, used by bounded hashed sets, to delete a node at
|
||||||
|
a given index, whose element may have been improperly updated
|
||||||
|
through a Reference_Preserving key.
|
||||||
|
* a-cbhase.ads: Add Reference_Control_Type to package Generic_Keys.
|
||||||
|
* a-cbhase.adb: Add Adjust and Finalize routines for
|
||||||
|
Reference_Control_Type.
|
||||||
|
(Delete, Insert): Raise Program_Error, not Constraint_Error,
|
||||||
|
when operation is illegal.
|
||||||
|
(Reference_Preserving_Key): Build aggregate for Reference_Control_Type
|
||||||
|
* a-cmbutr.ads: Add Reference_Control_Type to detect tampering. Add
|
||||||
|
private with_clause for Ada.Finalization.
|
||||||
|
* a-cbmutr.adb: Add Adjust and Finalize routines for
|
||||||
|
Reference_Control_Type. Use it in the construction of Reference
|
||||||
|
and Constant_Reference values.
|
||||||
|
|
||||||
2014-07-30 Robert Dewar <dewar@adacore.com>
|
2014-07-30 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* sem_ch3.adb, sem_ch3.ads: Minor code reorganization.
|
* sem_ch3.adb, sem_ch3.ads: Minor code reorganization.
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- --
|
-- --
|
||||||
-- GNAT LIBRARY COMPONENTS --
|
-- GNAT LIBRARY COMPONENTS --
|
||||||
-- --
|
-- --
|
||||||
|
@ -313,7 +313,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
|
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
|
||||||
|
|
||||||
if X = 0 then
|
if X = 0 then
|
||||||
raise Constraint_Error with "attempt to delete element not in set";
|
raise Program_Error with "attempt to delete element not in set";
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
HT_Ops.Free (Container, X);
|
HT_Ops.Free (Container, X);
|
||||||
|
@ -762,7 +762,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
Insert (Container, New_Item, Position, Inserted);
|
Insert (Container, New_Item, Position, Inserted);
|
||||||
|
|
||||||
if not Inserted then
|
if not Inserted then
|
||||||
raise Constraint_Error with
|
raise Program_Error with
|
||||||
"attempt to insert element already in set";
|
"attempt to insert element already in set";
|
||||||
end if;
|
end if;
|
||||||
end Insert;
|
end Insert;
|
||||||
|
@ -1621,6 +1621,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
-- Local Subprograms --
|
-- Local Subprograms --
|
||||||
-----------------------
|
-----------------------
|
||||||
|
|
||||||
|
------------
|
||||||
|
-- Adjust --
|
||||||
|
------------
|
||||||
|
|
||||||
|
procedure Adjust (Control : in out Reference_Control_Type) is
|
||||||
|
begin
|
||||||
|
if Control.Container /= null then
|
||||||
|
declare
|
||||||
|
B : Natural renames Control.Container.Busy;
|
||||||
|
L : Natural renames Control.Container.Lock;
|
||||||
|
begin
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end;
|
||||||
|
end if;
|
||||||
|
end Adjust;
|
||||||
|
|
||||||
function Equivalent_Key_Node
|
function Equivalent_Key_Node
|
||||||
(Key : Key_Type;
|
(Key : Key_Type;
|
||||||
Node : Node_Type) return Boolean;
|
Node : Node_Type) return Boolean;
|
||||||
|
@ -1751,6 +1768,32 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
HT_Ops.Free (Container, X);
|
HT_Ops.Free (Container, X);
|
||||||
end Exclude;
|
end Exclude;
|
||||||
|
|
||||||
|
--------------
|
||||||
|
-- Finalize --
|
||||||
|
--------------
|
||||||
|
|
||||||
|
procedure Finalize (Control : in out Reference_Control_Type) is
|
||||||
|
begin
|
||||||
|
if Control.Container /= null then
|
||||||
|
declare
|
||||||
|
B : Natural renames Control.Container.Busy;
|
||||||
|
L : Natural renames Control.Container.Lock;
|
||||||
|
begin
|
||||||
|
B := B - 1;
|
||||||
|
L := L - 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
|
||||||
|
then
|
||||||
|
HT_Ops.Delete_Node_At_Index
|
||||||
|
(Control.Container.all, Control.Index, Control.Old_Pos.Node);
|
||||||
|
raise Program_Error with "key not preserved in reference";
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Control.Container := null;
|
||||||
|
end if;
|
||||||
|
end Finalize;
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- Find --
|
-- Find --
|
||||||
----------
|
----------
|
||||||
|
@ -1815,14 +1858,25 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
(Vet (Position),
|
(Vet (Position),
|
||||||
"bad cursor in function Reference_Preserving_Key");
|
"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
|
declare
|
||||||
N : Node_Type renames Container.Nodes (Position.Node);
|
N : Node_Type renames Container.Nodes (Position.Node);
|
||||||
|
B : Natural renames Container.Busy;
|
||||||
|
L : Natural renames Container.Lock;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return (Element => N.Element'Access);
|
return R : constant Reference_Type :=
|
||||||
|
(Element => N.Element'Unrestricted_Access,
|
||||||
|
Control =>
|
||||||
|
(Controlled with
|
||||||
|
Container'Unrestricted_Access,
|
||||||
|
Index =>
|
||||||
|
Key_Keys.Index (Container, Key (Position)),
|
||||||
|
Old_Pos => Position,
|
||||||
|
Old_Hash => Hash (Key (Position))))
|
||||||
|
do
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end return;
|
||||||
end;
|
end;
|
||||||
end Reference_Preserving_Key;
|
end Reference_Preserving_Key;
|
||||||
|
|
||||||
|
@ -1838,9 +1892,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
declare
|
declare
|
||||||
N : Node_Type renames Container.Nodes (Node);
|
P : constant Cursor := Find (Container, Key);
|
||||||
|
B : Natural renames Container.Busy;
|
||||||
|
L : Natural renames Container.Lock;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return (Element => N.Element'Access);
|
return R : constant Reference_Type :=
|
||||||
|
(Element => Container.Nodes (Node).Element'Unrestricted_Access,
|
||||||
|
Control =>
|
||||||
|
(Controlled with
|
||||||
|
Container'Unrestricted_Access,
|
||||||
|
Index => Key_Keys.Index (Container, Key),
|
||||||
|
Old_Pos => P,
|
||||||
|
Old_Hash => Hash (Key)))
|
||||||
|
do
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end return;
|
||||||
end;
|
end;
|
||||||
end Reference_Preserving_Key;
|
end Reference_Preserving_Key;
|
||||||
|
|
||||||
|
|
|
@ -444,8 +444,29 @@ package Ada.Containers.Bounded_Hashed_Sets is
|
||||||
Key : Key_Type) return Reference_Type;
|
Key : Key_Type) return Reference_Type;
|
||||||
|
|
||||||
private
|
private
|
||||||
type Reference_Type (Element : not null access Element_Type) is
|
type Set_Access is access all Set;
|
||||||
null record;
|
for Set_Access'Storage_Size use 0;
|
||||||
|
|
||||||
|
type Reference_Control_Type is
|
||||||
|
new Ada.Finalization.Controlled with
|
||||||
|
record
|
||||||
|
Container : Set_Access;
|
||||||
|
Index : Hash_Type;
|
||||||
|
Old_Pos : Cursor;
|
||||||
|
Old_Hash : Hash_Type;
|
||||||
|
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;
|
use Ada.Streams;
|
||||||
|
|
||||||
|
|
|
@ -27,8 +27,6 @@
|
||||||
-- This unit was originally developed by Matthew J Heaney. --
|
-- This unit was originally developed by Matthew J Heaney. --
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with Ada.Finalization; use Ada.Finalization;
|
|
||||||
|
|
||||||
with System; use type System.Address;
|
with System; use type System.Address;
|
||||||
|
|
||||||
package body Ada.Containers.Bounded_Multiway_Trees is
|
package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
|
@ -236,6 +234,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
Right_Subtree => Root_Node (Right));
|
Right_Subtree => Root_Node (Right));
|
||||||
end "=";
|
end "=";
|
||||||
|
|
||||||
|
------------
|
||||||
|
-- Adjust --
|
||||||
|
------------
|
||||||
|
|
||||||
|
procedure Adjust (Control : in out Reference_Control_Type) is
|
||||||
|
begin
|
||||||
|
if Control.Container /= null then
|
||||||
|
declare
|
||||||
|
C : Tree renames Control.Container.all;
|
||||||
|
B : Natural renames C.Busy;
|
||||||
|
L : Natural renames C.Lock;
|
||||||
|
begin
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end;
|
||||||
|
end if;
|
||||||
|
end Adjust;
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
-- Allocate_Node --
|
-- Allocate_Node --
|
||||||
-------------------
|
-------------------
|
||||||
|
@ -329,12 +345,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
raise Constraint_Error with "Position cursor has no element";
|
raise Constraint_Error with "Position cursor has no element";
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Commented-out pending ruling by ARG. ???
|
|
||||||
|
|
||||||
-- if Position.Container /= Container'Unrestricted_Access then
|
|
||||||
-- raise Program_Error with "Position cursor not in container";
|
|
||||||
-- end if;
|
|
||||||
|
|
||||||
-- AI-0136 says to raise PE if Position equals the root node. This does
|
-- AI-0136 says to raise PE if Position equals the root node. This does
|
||||||
-- not seem correct, as this value is just the limiting condition of the
|
-- not seem correct, as this value is just the limiting condition of the
|
||||||
-- search. For now we omit this check, pending a ruling from the ARG.
|
-- search. For now we omit this check, pending a ruling from the ARG.
|
||||||
|
@ -602,7 +612,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
-- pragma Assert (Vet (Position),
|
-- pragma Assert (Vet (Position),
|
||||||
-- "Position cursor in Constant_Reference is bad");
|
-- "Position cursor in Constant_Reference is bad");
|
||||||
|
|
||||||
return (Element => Container.Elements (Position.Node)'Access);
|
declare
|
||||||
|
C : Tree renames Position.Container.all;
|
||||||
|
B : Natural renames C.Busy;
|
||||||
|
L : Natural renames C.Lock;
|
||||||
|
|
||||||
|
begin
|
||||||
|
return R : constant Constant_Reference_Type :=
|
||||||
|
(Element => Container.Elements (Position.Node)'Access,
|
||||||
|
Control => (Controlled with Container'Unrestricted_Access))
|
||||||
|
do
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end return;
|
||||||
|
end;
|
||||||
end Constant_Reference;
|
end Constant_Reference;
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
|
@ -1270,6 +1293,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
B := B - 1;
|
B := B - 1;
|
||||||
end Finalize;
|
end Finalize;
|
||||||
|
|
||||||
|
procedure Finalize (Control : in out Reference_Control_Type) is
|
||||||
|
begin
|
||||||
|
if Control.Container /= null then
|
||||||
|
declare
|
||||||
|
C : Tree renames Control.Container.all;
|
||||||
|
B : Natural renames C.Busy;
|
||||||
|
L : Natural renames C.Lock;
|
||||||
|
begin
|
||||||
|
B := B - 1;
|
||||||
|
L := L - 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
Control.Container := null;
|
||||||
|
end if;
|
||||||
|
end Finalize;
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- Find --
|
-- Find --
|
||||||
----------
|
----------
|
||||||
|
@ -2516,7 +2555,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is
|
||||||
-- pragma Assert (Vet (Position),
|
-- pragma Assert (Vet (Position),
|
||||||
-- "Position cursor in Constant_Reference is bad");
|
-- "Position cursor in Constant_Reference is bad");
|
||||||
|
|
||||||
return (Element => Container.Elements (Position.Node)'Access);
|
declare
|
||||||
|
C : Tree renames Position.Container.all;
|
||||||
|
B : Natural renames C.Busy;
|
||||||
|
L : Natural renames C.Lock;
|
||||||
|
begin
|
||||||
|
return R : constant Reference_Type :=
|
||||||
|
(Element => Container.Elements (Position.Node)'Access,
|
||||||
|
Control => (Controlled with Position.Container))
|
||||||
|
do
|
||||||
|
B := B + 1;
|
||||||
|
L := L + 1;
|
||||||
|
end return;
|
||||||
|
end;
|
||||||
|
|
||||||
end Reference;
|
end Reference;
|
||||||
|
|
||||||
--------------------
|
--------------------
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
|
-- Copyright (C) 2014, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- This specification is derived from the Ada Reference Manual for use with --
|
-- This specification is derived from the Ada Reference Manual for use with --
|
||||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||||
|
@ -33,6 +33,7 @@
|
||||||
|
|
||||||
with Ada.Iterator_Interfaces;
|
with Ada.Iterator_Interfaces;
|
||||||
private with Ada.Streams;
|
private with Ada.Streams;
|
||||||
|
private with Ada.Finalization;
|
||||||
|
|
||||||
generic
|
generic
|
||||||
type Element_Type is private;
|
type Element_Type is private;
|
||||||
|
@ -137,34 +138,10 @@ package Ada.Containers.Bounded_Multiway_Trees is
|
||||||
(Container : Tree;
|
(Container : Tree;
|
||||||
Item : Element_Type) return Cursor;
|
Item : Element_Type) return Cursor;
|
||||||
|
|
||||||
-- This version of the AI:
|
|
||||||
-- 10-06-02 AI05-0136-1/07
|
|
||||||
-- declares Find_In_Subtree this way:
|
|
||||||
--
|
|
||||||
-- function Find_In_Subtree
|
|
||||||
-- (Container : Tree;
|
|
||||||
-- Item : Element_Type;
|
|
||||||
-- Position : Cursor) return Cursor;
|
|
||||||
--
|
|
||||||
-- It seems that the Container parameter is there by mistake, but we need
|
|
||||||
-- an official ruling from the ARG. ???
|
|
||||||
|
|
||||||
function Find_In_Subtree
|
function Find_In_Subtree
|
||||||
(Position : Cursor;
|
(Position : Cursor;
|
||||||
Item : Element_Type) return Cursor;
|
Item : Element_Type) return Cursor;
|
||||||
|
|
||||||
-- This version of the AI:
|
|
||||||
-- 10-06-02 AI05-0136-1/07
|
|
||||||
-- declares Ancestor_Find this way:
|
|
||||||
--
|
|
||||||
-- function Ancestor_Find
|
|
||||||
-- (Container : Tree;
|
|
||||||
-- Item : Element_Type;
|
|
||||||
-- Position : Cursor) return Cursor;
|
|
||||||
--
|
|
||||||
-- It seems that the Container parameter is there by mistake, but we need
|
|
||||||
-- an official ruling from the ARG. ???
|
|
||||||
|
|
||||||
function Ancestor_Find
|
function Ancestor_Find
|
||||||
(Position : Cursor;
|
(Position : Cursor;
|
||||||
Item : Element_Type) return Cursor;
|
Item : Element_Type) return Cursor;
|
||||||
|
@ -284,20 +261,6 @@ package Ada.Containers.Bounded_Multiway_Trees is
|
||||||
|
|
||||||
procedure Previous_Sibling (Position : in out Cursor);
|
procedure Previous_Sibling (Position : in out Cursor);
|
||||||
|
|
||||||
-- This version of the AI:
|
|
||||||
|
|
||||||
-- 10-06-02 AI05-0136-1/07
|
|
||||||
|
|
||||||
-- declares Iterate_Children this way:
|
|
||||||
|
|
||||||
-- procedure Iterate_Children
|
|
||||||
-- (Container : Tree;
|
|
||||||
-- Parent : Cursor;
|
|
||||||
-- Process : not null access procedure (Position : Cursor));
|
|
||||||
|
|
||||||
-- It seems that the Container parameter is there by mistake, but we need
|
|
||||||
-- an official ruling from the ARG. ???
|
|
||||||
|
|
||||||
procedure Iterate_Children
|
procedure Iterate_Children
|
||||||
(Parent : Cursor;
|
(Parent : Cursor;
|
||||||
Process : not null access procedure (Position : Cursor));
|
Process : not null access procedure (Position : Cursor));
|
||||||
|
@ -308,6 +271,7 @@ package Ada.Containers.Bounded_Multiway_Trees is
|
||||||
|
|
||||||
private
|
private
|
||||||
use Ada.Streams;
|
use Ada.Streams;
|
||||||
|
use Ada.Finalization;
|
||||||
|
|
||||||
No_Node : constant Count_Type'Base := -1;
|
No_Node : constant Count_Type'Base := -1;
|
||||||
-- Need to document all global declarations such as this ???
|
-- Need to document all global declarations such as this ???
|
||||||
|
@ -368,8 +332,22 @@ private
|
||||||
Position : Cursor);
|
Position : Cursor);
|
||||||
for Cursor'Write use Write;
|
for Cursor'Write use Write;
|
||||||
|
|
||||||
|
type Reference_Control_Type is
|
||||||
|
new Controlled with record
|
||||||
|
Container : Tree_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 Constant_Reference_Type
|
type Constant_Reference_Type
|
||||||
(Element : not null access constant Element_Type) is null record;
|
(Element : not null access constant Element_Type) is
|
||||||
|
record
|
||||||
|
Control : Reference_Control_Type;
|
||||||
|
end record;
|
||||||
|
|
||||||
procedure Write
|
procedure Write
|
||||||
(Stream : not null access Root_Stream_Type'Class;
|
(Stream : not null access Root_Stream_Type'Class;
|
||||||
|
@ -382,7 +360,10 @@ private
|
||||||
for Constant_Reference_Type'Read use Read;
|
for Constant_Reference_Type'Read use Read;
|
||||||
|
|
||||||
type Reference_Type
|
type Reference_Type
|
||||||
(Element : not null access Element_Type) is null record;
|
(Element : not null access Element_Type) is
|
||||||
|
record
|
||||||
|
Control : Reference_Control_Type;
|
||||||
|
end record;
|
||||||
|
|
||||||
procedure Write
|
procedure Write
|
||||||
(Stream : not null access Root_Stream_Type'Class;
|
(Stream : not null access Root_Stream_Type'Class;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -81,6 +81,48 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
|
||||||
HT.Buckets := (others => 0); -- optimize this somehow ???
|
HT.Buckets := (others => 0); -- optimize this somehow ???
|
||||||
end Clear;
|
end Clear;
|
||||||
|
|
||||||
|
--------------------------
|
||||||
|
-- Delete_Node_At_Index --
|
||||||
|
--------------------------
|
||||||
|
|
||||||
|
procedure Delete_Node_At_Index
|
||||||
|
(HT : in out Hash_Table_Type'Class;
|
||||||
|
Indx : Hash_Type;
|
||||||
|
X : Count_Type)
|
||||||
|
is
|
||||||
|
Prev : Count_Type;
|
||||||
|
Curr : Count_Type;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Prev := HT.Buckets (Indx);
|
||||||
|
|
||||||
|
if Prev = 0 then
|
||||||
|
raise Program_Error with
|
||||||
|
"attempt to delete node from empty hash bucket";
|
||||||
|
end if;
|
||||||
|
|
||||||
|
if Prev = X then
|
||||||
|
HT.Buckets (Indx) := Next (HT.Nodes (Prev));
|
||||||
|
HT.Length := HT.Length - 1;
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
if HT.Length = 1 then
|
||||||
|
raise Program_Error with
|
||||||
|
"attempt to delete node not in its proper hash bucket";
|
||||||
|
end if;
|
||||||
|
|
||||||
|
loop
|
||||||
|
Curr := Next (HT.Nodes (Prev));
|
||||||
|
|
||||||
|
if Curr = 0 then
|
||||||
|
raise Program_Error with
|
||||||
|
"attempt to delete node not in its proper hash bucket";
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Prev := Curr;
|
||||||
|
end loop;
|
||||||
|
end Delete_Node_At_Index;
|
||||||
|
|
||||||
---------------------------
|
---------------------------
|
||||||
-- Delete_Node_Sans_Free --
|
-- Delete_Node_Sans_Free --
|
||||||
---------------------------
|
---------------------------
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- --
|
-- --
|
||||||
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -84,6 +84,17 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
|
||||||
-- the nodes, not the buckets array.) Program_Error is raised if the hash
|
-- the nodes, not the buckets array.) Program_Error is raised if the hash
|
||||||
-- table is busy.
|
-- table is busy.
|
||||||
|
|
||||||
|
procedure Delete_Node_At_Index
|
||||||
|
(HT : in out Hash_Table_Type'Class;
|
||||||
|
Indx : Hash_Type;
|
||||||
|
X : Count_Type);
|
||||||
|
|
||||||
|
-- Delete a node whose bucket position is known. extracted from following
|
||||||
|
-- subprogram, but also used directly to remove a node whose element has
|
||||||
|
-- been modified through a key_preserving reference: in that case we cannot
|
||||||
|
-- use the value of the element precisely because the current value does
|
||||||
|
-- not correspond to the hash code that determines its bucket.
|
||||||
|
|
||||||
procedure Delete_Node_Sans_Free
|
procedure Delete_Node_Sans_Free
|
||||||
(HT : in out Hash_Table_Type'Class;
|
(HT : in out Hash_Table_Type'Class;
|
||||||
X : Count_Type);
|
X : Count_Type);
|
||||||
|
|
|
@ -740,11 +740,12 @@ package body Clean is
|
||||||
if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
|
if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
|
||||||
declare
|
declare
|
||||||
Unit : Unit_Index;
|
Unit : Unit_Index;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Compare with ALI file names of the project
|
-- Compare with ALI file names of the project
|
||||||
|
|
||||||
Unit := Units_Htable.Get_First
|
Unit :=
|
||||||
(Project_Tree.Units_HT);
|
Units_Htable.Get_First (Project_Tree.Units_HT);
|
||||||
while Unit /= No_Unit_Index loop
|
while Unit /= No_Unit_Index loop
|
||||||
if Unit.File_Names (Impl) /= null
|
if Unit.File_Names (Impl) /= null
|
||||||
and then Unit.File_Names (Impl).Project /=
|
and then Unit.File_Names (Impl).Project /=
|
||||||
|
@ -756,9 +757,10 @@ package body Clean is
|
||||||
then
|
then
|
||||||
Get_Name_String
|
Get_Name_String
|
||||||
(Unit.File_Names (Impl).File);
|
(Unit.File_Names (Impl).File);
|
||||||
Name_Len := Name_Len -
|
Name_Len :=
|
||||||
File_Extension
|
Name_Len -
|
||||||
(Name (1 .. Name_Len))'Length;
|
File_Extension
|
||||||
|
(Name (1 .. Name_Len))'Length;
|
||||||
if Name_Buffer (1 .. Name_Len) =
|
if Name_Buffer (1 .. Name_Len) =
|
||||||
Name (1 .. Last - 4)
|
Name (1 .. Last - 4)
|
||||||
then
|
then
|
||||||
|
@ -772,8 +774,7 @@ package body Clean is
|
||||||
(Unit.File_Names (Spec).Project) =
|
(Unit.File_Names (Spec).Project) =
|
||||||
Project
|
Project
|
||||||
then
|
then
|
||||||
Get_Name_String
|
Get_Name_String (Unit.File_Names (Spec).File);
|
||||||
(Unit.File_Names (Spec).File);
|
|
||||||
Name_Len :=
|
Name_Len :=
|
||||||
Name_Len -
|
Name_Len -
|
||||||
File_Extension
|
File_Extension
|
||||||
|
@ -869,7 +870,7 @@ package body Clean is
|
||||||
|
|
||||||
if Project.Object_Directory /= No_Path_Information
|
if Project.Object_Directory /= No_Path_Information
|
||||||
and then Is_Directory
|
and then Is_Directory
|
||||||
(Get_Name_String (Project.Object_Directory.Display_Name))
|
(Get_Name_String (Project.Object_Directory.Display_Name))
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Obj_Dir : constant String :=
|
Obj_Dir : constant String :=
|
||||||
|
@ -904,8 +905,9 @@ package body Clean is
|
||||||
(Unit.File_Names (Impl).Project, Project))
|
(Unit.File_Names (Impl).Project, Project))
|
||||||
or else
|
or else
|
||||||
(Unit.File_Names (Spec) /= null
|
(Unit.File_Names (Spec) /= null
|
||||||
and then In_Extension_Chain
|
and then
|
||||||
(Unit.File_Names (Spec).Project, Project))
|
In_Extension_Chain
|
||||||
|
(Unit.File_Names (Spec).Project, Project))
|
||||||
then
|
then
|
||||||
if Unit.File_Names (Impl) /= null then
|
if Unit.File_Names (Impl) /= null then
|
||||||
File_Name1 := Unit.File_Names (Impl).File;
|
File_Name1 := Unit.File_Names (Impl).File;
|
||||||
|
@ -942,17 +944,17 @@ package body Clean is
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Asm : constant String :=
|
Asm : constant String :=
|
||||||
Assembly_File_Name (Lib_File);
|
Assembly_File_Name (Lib_File);
|
||||||
ALI : constant String :=
|
ALI : constant String :=
|
||||||
ALI_File_Name (Lib_File);
|
ALI_File_Name (Lib_File);
|
||||||
Obj : constant String :=
|
Obj : constant String :=
|
||||||
Object_File_Name (Lib_File);
|
Object_File_Name (Lib_File);
|
||||||
Adt : constant String :=
|
Adt : constant String :=
|
||||||
Tree_File_Name (Lib_File);
|
Tree_File_Name (Lib_File);
|
||||||
Deb : constant String :=
|
Deb : constant String :=
|
||||||
Debug_File_Name (File_Name1);
|
Debug_File_Name (File_Name1);
|
||||||
Rep : constant String :=
|
Rep : constant String :=
|
||||||
Repinfo_File_Name (File_Name1);
|
Repinfo_File_Name (File_Name1);
|
||||||
Del : Boolean := True;
|
Del : Boolean := True;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -1199,8 +1201,9 @@ package body Clean is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
if Project.Object_Directory /= No_Path_Information
|
if Project.Object_Directory /= No_Path_Information
|
||||||
and then Is_Directory
|
and then
|
||||||
(Get_Name_String (Project.Object_Directory.Display_Name))
|
Is_Directory
|
||||||
|
(Get_Name_String (Project.Object_Directory.Display_Name))
|
||||||
then
|
then
|
||||||
Delete_Binder_Generated_Files
|
Delete_Binder_Generated_Files
|
||||||
(Get_Name_String (Project.Object_Directory.Display_Name),
|
(Get_Name_String (Project.Object_Directory.Display_Name),
|
||||||
|
@ -1811,8 +1814,7 @@ package body Clean is
|
||||||
declare
|
declare
|
||||||
Prj : constant String := Arg (3 .. Arg'Last);
|
Prj : constant String := Arg (3 .. Arg'Last);
|
||||||
begin
|
begin
|
||||||
if Prj'Length > 1 and then
|
if Prj'Length > 1 and then Prj (Prj'First) = '='
|
||||||
Prj (Prj'First) = '='
|
|
||||||
then
|
then
|
||||||
Project_File_Name :=
|
Project_File_Name :=
|
||||||
new String'
|
new String'
|
||||||
|
|
|
@ -224,7 +224,7 @@ package Opt is
|
||||||
-- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end
|
-- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end
|
||||||
-- assumes that values could have invalid representations, unless it can
|
-- assumes that values could have invalid representations, unless it can
|
||||||
-- clearly prove that the values are valid. If this switch is set (by
|
-- clearly prove that the values are valid. If this switch is set (by
|
||||||
-- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values
|
-- pragma Assume_No_Invalid_Values (On)), then the compiler assumes values
|
||||||
-- are valid and in range of their representations. This feature is now
|
-- are valid and in range of their representations. This feature is now
|
||||||
-- fully enabled in the compiler.
|
-- fully enabled in the compiler.
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue