+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>
* sem_ch3.adb, sem_ch3.ads: Minor code reorganization.
-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
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;
HT_Ops.Free (Container, X);
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error with
+ raise Program_Error with
"attempt to insert element already in set";
end if;
end Insert;
-- 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
(Key : Key_Type;
Node : Node_Type) return Boolean;
HT_Ops.Free (Container, X);
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 --
----------
(Vet (Position),
"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
N : Node_Type renames Container.Nodes (Position.Node);
+ B : Natural renames Container.Busy;
+ L : Natural renames Container.Lock;
+
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 Reference_Preserving_Key;
end if;
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
- 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 Reference_Preserving_Key;
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 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;
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Finalization; use Ada.Finalization;
-
with System; use type System.Address;
package body Ada.Containers.Bounded_Multiway_Trees is
Right_Subtree => Root_Node (Right));
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 --
-------------------
raise Constraint_Error with "Position cursor has no element";
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
-- 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.
-- pragma Assert (Vet (Position),
-- "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;
--------------
B := B - 1;
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 --
----------
-- pragma Assert (Vet (Position),
-- "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;
--------------------
-- --
-- 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 --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Iterator_Interfaces;
private with Ada.Streams;
+private with Ada.Finalization;
generic
type Element_Type is private;
(Container : Tree;
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
(Position : 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
(Position : Cursor;
Item : Element_Type) return 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
(Parent : Cursor;
Process : not null access procedure (Position : Cursor));
private
use Ada.Streams;
+ use Ada.Finalization;
No_Node : constant Count_Type'Base := -1;
-- Need to document all global declarations such as this ???
Position : Cursor);
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
- (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
(Stream : not null access Root_Stream_Type'Class;
for Constant_Reference_Type'Read use Read;
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
(Stream : not null access Root_Stream_Type'Class;
-- --
-- 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- --
HT.Buckets := (others => 0); -- optimize this somehow ???
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 --
---------------------------
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- the nodes, not the buckets array.) Program_Error is raised if the hash
-- 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
(HT : in out Hash_Table_Type'Class;
X : Count_Type);
if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
declare
Unit : Unit_Index;
+
begin
-- Compare with ALI file names of the project
- Unit := Units_Htable.Get_First
- (Project_Tree.Units_HT);
+ Unit :=
+ Units_Htable.Get_First (Project_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Project /=
then
Get_Name_String
(Unit.File_Names (Impl).File);
- Name_Len := Name_Len -
- File_Extension
- (Name (1 .. Name_Len))'Length;
+ Name_Len :=
+ Name_Len -
+ File_Extension
+ (Name (1 .. Name_Len))'Length;
if Name_Buffer (1 .. Name_Len) =
Name (1 .. Last - 4)
then
(Unit.File_Names (Spec).Project) =
Project
then
- Get_Name_String
- (Unit.File_Names (Spec).File);
+ Get_Name_String (Unit.File_Names (Spec).File);
Name_Len :=
Name_Len -
File_Extension
if Project.Object_Directory /= No_Path_Information
and then Is_Directory
- (Get_Name_String (Project.Object_Directory.Display_Name))
+ (Get_Name_String (Project.Object_Directory.Display_Name))
then
declare
Obj_Dir : constant String :=
(Unit.File_Names (Impl).Project, Project))
or else
(Unit.File_Names (Spec) /= null
- and then In_Extension_Chain
- (Unit.File_Names (Spec).Project, Project))
+ and then
+ In_Extension_Chain
+ (Unit.File_Names (Spec).Project, Project))
then
if Unit.File_Names (Impl) /= null then
File_Name1 := Unit.File_Names (Impl).File;
declare
Asm : constant String :=
- Assembly_File_Name (Lib_File);
+ Assembly_File_Name (Lib_File);
ALI : constant String :=
- ALI_File_Name (Lib_File);
+ ALI_File_Name (Lib_File);
Obj : constant String :=
- Object_File_Name (Lib_File);
+ Object_File_Name (Lib_File);
Adt : constant String :=
- Tree_File_Name (Lib_File);
+ Tree_File_Name (Lib_File);
Deb : constant String :=
- Debug_File_Name (File_Name1);
+ Debug_File_Name (File_Name1);
Rep : constant String :=
- Repinfo_File_Name (File_Name1);
+ Repinfo_File_Name (File_Name1);
Del : Boolean := True;
begin
end if;
if Project.Object_Directory /= No_Path_Information
- and then Is_Directory
- (Get_Name_String (Project.Object_Directory.Display_Name))
+ and then
+ Is_Directory
+ (Get_Name_String (Project.Object_Directory.Display_Name))
then
Delete_Binder_Generated_Files
(Get_Name_String (Project.Object_Directory.Display_Name),
declare
Prj : constant String := Arg (3 .. Arg'Last);
begin
- if Prj'Length > 1 and then
- Prj (Prj'First) = '='
+ if Prj'Length > 1 and then Prj (Prj'First) = '='
then
Project_File_Name :=
new String'
-- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end
-- assumes that values could have invalid representations, unless it can
-- 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
-- fully enabled in the compiler.
projects / gcc.git / commitdiff