* Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
@ 2005-08-06 11:57 Y.Tomino
2005-08-06 12:54 ` Matthew Heaney
0 siblings, 1 reply; 7+ messages in thread
From: Y.Tomino @ 2005-08-06 11:57 UTC (permalink / raw)
Hello.
Ada.Containers.Indefinite_Ordered_Maps.Adjust seems to me having bug.
Although good if it's my misunderstanding.
pragma Ada_05;
with Ada.Containers.Indefinite_Ordered_Maps;
package M is new Ada.Containers.Indefinite_Ordered_Maps(String, String);
pragma Ada_05;
with Ada.Text_IO; use Ada.Text_IO;
with m; use M;
procedure Test1 is
X, Y : Map;
begin
X.Include("a", "1");
Put_Line(Element(X, "a")); -- "1" OK
Y := X;
Put_Line(Element(Y, "a")); -- "1" OK
Clear(X);
Put_Line(Element(Y, "a"));
-- raised CONSTRAINT_ERROR : a-ciorma.adb:407 access check failed !?
end Test1;
pragma Ada_05;
with Ada.Text_IO; use Ada.Text_IO;
with m; use M;
procedure Test2 is
function X return Map is
R : Map;
begin
R.Include("a", "1");
return R;
end X;
Y : Map := X;
begin
Put_Line(Element(Y, "a"));
-- raised CONSTRAINT_ERROR : a-ciorma.adb:407 access check failed !?
end Test2;
YT
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
2005-08-06 11:57 Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ? Y.Tomino
@ 2005-08-06 12:54 ` Matthew Heaney
2005-08-06 13:13 ` Y.Tomino
[not found] ` <42F4B753.2080004@panathenaia.halfmoon.jp>
0 siblings, 2 replies; 7+ messages in thread
From: Matthew Heaney @ 2005-08-06 12:54 UTC (permalink / raw)
"Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
> Ada.Containers.Indefinite_Ordered_Maps.Adjust seems to me having bug.
> Although good if it's my misunderstanding.
I just ran your examples, and didn't get any exceptions.
It might be the case that you're using an older version of the sources.
Can you go into your adainclude directory, and send me your copies of
a-ciorma.ad?. (That, or send me the context around line 407.)
-Matt
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
2005-08-06 12:54 ` Matthew Heaney
@ 2005-08-06 13:13 ` Y.Tomino
[not found] ` <42F4B753.2080004@panathenaia.halfmoon.jp>
1 sibling, 0 replies; 7+ messages in thread
From: Y.Tomino @ 2005-08-06 13:13 UTC (permalink / raw)
To: Matthew Heaney
[-- Attachment #1: Type: text/plain, Size: 745 bytes --]
I send a-ciorma.ad? as attachments.
(C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.ads,
C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.adb)
I built gcc 4.0.1 with "--enable-languages=c,ada,c++ --prefix=/mingw".
Thanks.
YT
Matthew Heaney wrote:
> "Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
>
>
>>Ada.Containers.Indefinite_Ordered_Maps.Adjust seems to me having bug.
>>Although good if it's my misunderstanding.
>
>
> I just ran your examples, and didn't get any exceptions.
>
> It might be the case that you're using an older version of the sources.
> Can you go into your adainclude directory, and send me your copies of
> a-ciorma.ad?. (That, or send me the context around line 407.)
>
> -Matt
[-- Attachment #2: a-ciorma.ads --]
[-- Type: text/plain, Size: 7655 bytes --]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Containers.Red_Black_Trees;
with Ada.Finalization;
with Ada.Streams;
generic
type Key_Type (<>) is private;
type Element_Type (<>) is private;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Ordered_Maps is
pragma Preelaborate (Indefinite_Ordered_Maps);
type Map is tagged private;
type Cursor is private;
Empty_Map : constant Map;
No_Element : constant Cursor;
function "=" (Left, Right : Map) return Boolean;
function Length (Container : Map) return Count_Type;
function Is_Empty (Container : Map) return Boolean;
procedure Clear (Container : in out Map);
function Key (Position : Cursor) return Key_Type;
function Element (Position : Cursor) return Element_Type;
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type));
procedure Replace_Element (Position : Cursor; By : Element_Type);
procedure Move (Target : in out Map; Source : in out Map);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Replace
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Delete
(Container : in out Map;
Key : Key_Type);
procedure Exclude
(Container : in out Map;
Key : Key_Type);
procedure Delete
(Container : in out Map;
Position : in out Cursor);
procedure Delete_First (Container : in out Map);
procedure Delete_Last (Container : in out Map);
function Contains
(Container : Map;
Key : Key_Type) return Boolean;
function Find
(Container : Map;
Key : Key_Type) return Cursor;
function Element
(Container : Map;
Key : Key_Type) return Element_Type;
function Floor
(Container : Map;
Key : Key_Type) return Cursor;
function Ceiling
(Container : Map;
Key : Key_Type) return Cursor;
function First (Container : Map) return Cursor;
function First_Key (Container : Map) return Key_Type;
function First_Element (Container : Map) return Element_Type;
function Last (Container : Map) return Cursor;
function Last_Key (Container : Map) return Key_Type;
function Last_Element (Container : Map) return Element_Type;
function Next (Position : Cursor) return Cursor;
function Previous (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function "<" (Left, Right : Cursor) return Boolean;
function ">" (Left, Right : Cursor) return Boolean;
function "<" (Left : Cursor; Right : Key_Type) return Boolean;
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
procedure Reverse_Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
private
type Node_Type;
type Node_Access is access Node_Type;
package Tree_Types is
new Red_Black_Trees.Generic_Tree_Types (Node_Access);
use Tree_Types;
use Ada.Finalization;
type Map is new Controlled with record
Tree : Tree_Type := (Length => 0, others => null);
end record;
procedure Adjust (Container : in out Map);
procedure Finalize (Container : in out Map) renames Clear;
type Map_Access is access constant Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
Container : Map_Access;
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
use Ada.Streams;
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map);
for Map'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map);
for Map'Read use Read;
Empty_Map : constant Map :=
(Controlled with Tree => (Length => 0, others => null));
end Ada.Containers.Indefinite_Ordered_Maps;
[-- Attachment #3: a-ciorma.adb --]
[-- Type: text/plain, Size: 25588 bytes --]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
with Ada.Containers.Red_Black_Trees.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
with System; use type System.Address;
package body Ada.Containers.Indefinite_Ordered_Maps is
use Red_Black_Trees;
type Key_Access is access Key_Type;
type Element_Access is access Element_Type;
type Node_Type is limited record
Parent : Node_Access;
Left : Node_Access;
Right : Node_Access;
Color : Red_Black_Trees.Color_Type := Red;
Key : Key_Access;
Element : Element_Access;
end record;
-----------------------------
-- Node Access Subprograms --
-----------------------------
-- These subprograms provide a functional interface to access fields
-- of a node, and a procedural interface for modifying these values.
function Color (Node : Node_Access) return Color_Type;
pragma Inline (Color);
function Left (Node : Node_Access) return Node_Access;
pragma Inline (Left);
function Parent (Node : Node_Access) return Node_Access;
pragma Inline (Parent);
function Right (Node : Node_Access) return Node_Access;
pragma Inline (Right);
procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
pragma Inline (Set_Parent);
procedure Set_Left (Node : Node_Access; Left : Node_Access);
pragma Inline (Set_Left);
procedure Set_Right (Node : Node_Access; Right : Node_Access);
pragma Inline (Set_Right);
procedure Set_Color (Node : Node_Access; Color : Color_Type);
pragma Inline (Set_Color);
-----------------------
-- Local Subprograms --
-----------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
function Copy_Tree (Source_Root : Node_Access) return Node_Access;
procedure Delete_Tree (X : in out Node_Access);
procedure Free (X : in out Node_Access);
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean;
pragma Inline (Is_Equal_Node_Node);
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean;
pragma Inline (Is_Greater_Key_Node);
function Is_Less_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean;
pragma Inline (Is_Less_Key_Node);
--------------------------
-- Local Instantiations --
--------------------------
package Tree_Operations is
new Red_Black_Trees.Generic_Operations
(Tree_Types => Tree_Types,
Null_Node => Node_Access'(null));
use Tree_Operations;
package Key_Ops is
new Red_Black_Trees.Generic_Keys
(Tree_Operations => Tree_Operations,
Key_Type => Key_Type,
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
procedure Free_Key is
new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
function Is_Equal is
new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
---------
-- "<" --
---------
function "<" (Left, Right : Cursor) return Boolean is
begin
return Left.Node.Key.all < Right.Node.Key.all;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Left.Node.Key.all < Right;
end "<";
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Key.all;
end "<";
---------
-- "=" --
---------
function "=" (Left, Right : Map) return Boolean is
begin
if Left'Address = Right'Address then
return True;
end if;
return Is_Equal (Left.Tree, Right.Tree);
end "=";
---------
-- ">" --
---------
function ">" (Left, Right : Cursor) return Boolean is
begin
return Right.Node.Key.all < Left.Node.Key.all;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Key.all;
end ">";
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Right.Node.Key.all < Left;
end ">";
------------
-- Adjust --
------------
procedure Adjust (Container : in out Map) is
Tree : Tree_Type renames Container.Tree;
N : constant Count_Type := Tree.Length;
X : constant Node_Access := Tree.Root;
begin
if N = 0 then
pragma Assert (X = null);
return;
end if;
Tree := (Length => 0, others => null);
Tree.Root := Copy_Tree (X);
Tree.First := Min (Tree.Root);
Tree.Last := Max (Tree.Root);
Tree.Length := N;
end Adjust;
-------------
-- Ceiling --
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Ceiling;
-----------
-- Clear --
-----------
procedure Clear (Container : in out Map) is
Tree : Tree_Type renames Container.Tree;
Root : Node_Access := Tree.Root;
begin
Tree := (Length => 0, others => null);
Delete_Tree (Root);
end Clear;
-----------
-- Color --
-----------
function Color (Node : Node_Access) return Color_Type is
begin
return Node.Color;
end Color;
--------------
-- Contains --
--------------
function Contains (Container : Map; Key : Key_Type) return Boolean is
begin
return Find (Container, Key) /= No_Element;
end Contains;
---------------
-- Copy_Node --
---------------
function Copy_Node (Source : Node_Access) return Node_Access is
Target : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Key => Source.Key,
Element => Source.Element);
begin
return Target;
end Copy_Node;
---------------
-- Copy_Tree --
---------------
function Copy_Tree (Source_Root : Node_Access) return Node_Access is
Target_Root : Node_Access := Copy_Node (Source_Root);
P, X : Node_Access;
begin
if Source_Root.Right /= null then
Target_Root.Right := Copy_Tree (Source_Root.Right);
Target_Root.Right.Parent := Target_Root;
end if;
P := Target_Root;
X := Source_Root.Left;
while X /= null loop
declare
Y : Node_Access := Copy_Node (X);
begin
P.Left := Y;
Y.Parent := P;
if X.Right /= null then
Y.Right := Copy_Tree (X.Right);
Y.Right.Parent := Y;
end if;
P := Y;
X := X.Left;
end;
end loop;
return Target_Root;
exception
when others =>
Delete_Tree (Target_Root);
raise;
end Copy_Tree;
------------
-- Delete --
------------
procedure Delete
(Container : in out Map;
Position : in out Cursor)
is
begin
if Position = No_Element then
return;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if X = null then
raise Constraint_Error;
else
Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Delete;
------------------
-- Delete_First --
------------------
procedure Delete_First (Container : in out Map) is
Position : Cursor := First (Container);
begin
Delete (Container, Position);
end Delete_First;
-----------------
-- Delete_Last --
-----------------
procedure Delete_Last (Container : in out Map) is
Position : Cursor := Last (Container);
begin
Delete (Container, Position);
end Delete_Last;
-----------------
-- Delete_Tree --
-----------------
procedure Delete_Tree (X : in out Node_Access) is
Y : Node_Access;
begin
while X /= null loop
Y := X.Right;
Delete_Tree (Y);
Y := X.Left;
Free (X);
X := Y;
end loop;
end Delete_Tree;
-------------
-- Element --
-------------
function Element (Position : Cursor) return Element_Type is
begin
return Position.Node.Element.all;
end Element;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
return Node.Element.all;
end Element;
-------------
-- Exclude --
-------------
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if X /= null then
Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
----------
-- Find --
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Find;
-----------
-- First --
-----------
function First (Container : Map) return Cursor is
begin
if Container.Tree.First = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Container.Tree.First);
end if;
end First;
-------------------
-- First_Element --
-------------------
function First_Element (Container : Map) return Element_Type is
begin
return Container.Tree.First.Element.all;
end First_Element;
---------------
-- First_Key --
---------------
function First_Key (Container : Map) return Key_Type is
begin
return Container.Tree.First.Key.all;
end First_Key;
-----------
-- Floor --
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Floor;
----------
-- Free --
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X /= null then
Free_Key (X.Key);
Free_Element (X.Element);
Deallocate (X);
end if;
end Free;
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
return Position /= No_Element;
end Has_Element;
-------------
-- Include --
-------------
procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Position : Cursor;
Inserted : Boolean;
K : Key_Access;
E : Element_Access;
begin
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
K := Position.Node.Key;
E := Position.Node.Element;
Position.Node.Key := new Key_Type'(Key);
Position.Node.Element := new Element_Type'(New_Item);
Free_Key (K);
Free_Element (E);
end if;
end Include;
------------
-- Insert --
------------
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean)
is
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
procedure Insert_Sans_Hint is
new Key_Ops.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
begin
Node.Key := new Key_Type'(Key);
Node.Element := new Element_Type'(New_Item);
return Node;
exception
when others =>
-- On exception, deallocate key and elem
Free (Node);
raise;
end New_Node;
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container.Tree,
Key,
Position.Node,
Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Position : Cursor;
Inserted : Boolean;
begin
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
raise Constraint_Error;
end if;
end Insert;
--------------
-- Is_Empty --
--------------
function Is_Empty (Container : Map) return Boolean is
begin
return Container.Tree.Length = 0;
end Is_Empty;
------------------------
-- Is_Equal_Node_Node --
------------------------
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean is
begin
return L.Element.all = R.Element.all;
end Is_Equal_Node_Node;
-------------------------
-- Is_Greater_Key_Node --
-------------------------
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean
is
begin
-- k > node same as node < k
return Right.Key.all < Left;
end Is_Greater_Key_Node;
----------------------
-- Is_Less_Key_Node --
----------------------
function Is_Less_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left < Right.Key.all;
end Is_Less_Key_Node;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Iterate is
new Tree_Operations.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
-- Start of processing for Iterate
begin
Local_Iterate (Container.Tree);
end Iterate;
---------
-- Key --
---------
function Key (Position : Cursor) return Key_Type is
begin
return Position.Node.Key.all;
end Key;
----------
-- Last --
----------
function Last (Container : Map) return Cursor is
begin
if Container.Tree.Last = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
end if;
end Last;
------------------
-- Last_Element --
------------------
function Last_Element (Container : Map) return Element_Type is
begin
return Container.Tree.Last.Element.all;
end Last_Element;
--------------
-- Last_Key --
--------------
function Last_Key (Container : Map) return Key_Type is
begin
return Container.Tree.Last.Key.all;
end Last_Key;
----------
-- Left --
----------
function Left (Node : Node_Access) return Node_Access is
begin
return Node.Left;
end Left;
------------
-- Length --
------------
function Length (Container : Map) return Count_Type is
begin
return Container.Tree.Length;
end Length;
----------
-- Move --
----------
procedure Move (Target : in out Map; Source : in out Map) is
begin
if Target'Address = Source'Address then
return;
end if;
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
----------
-- Next --
----------
function Next (Position : Cursor) return Cursor is
begin
if Position = No_Element then
return No_Element;
end if;
declare
Node : constant Node_Access := Tree_Operations.Next (Position.Node);
begin
if Node = null then
return No_Element;
else
return Cursor'(Position.Container, Node);
end if;
end;
end Next;
procedure Next (Position : in out Cursor) is
begin
Position := Next (Position);
end Next;
------------
-- Parent --
------------
function Parent (Node : Node_Access) return Node_Access is
begin
return Node.Parent;
end Parent;
--------------
-- Previous --
--------------
function Previous (Position : Cursor) return Cursor is
begin
if Position = No_Element then
return No_Element;
end if;
declare
Node : constant Node_Access :=
Tree_Operations.Previous (Position.Node);
begin
if Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Node);
end;
end Previous;
procedure Previous (Position : in out Cursor) is
begin
Position := Previous (Position);
end Previous;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
begin
Process (Position.Node.Key.all, Position.Node.Element.all);
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map)
is
N : Count_Type'Base;
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
begin
Node.Key := new Key_Type'(Key_Type'Input (Stream));
Node.Element := new Element_Type'(Element_Type'Input (Stream));
return Node;
exception
when others =>
-- Deallocate key and elem too on exception
Free (Node);
raise;
end New_Node;
-- Start of processing for Read
begin
Clear (Container);
Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
Local_Read (Container.Tree, N);
end Read;
-------------
-- Replace --
-------------
procedure Replace
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Node : constant Node_Access :=
Key_Ops.Find (Container.Tree, Key);
K : Key_Access;
E : Element_Access;
begin
if Node = null then
raise Constraint_Error;
end if;
K := Node.Key;
E := Node.Element;
Node.Key := new Key_Type'(Key);
Node.Element := new Element_Type'(New_Item);
Free_Key (K);
Free_Element (E);
end Replace;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end Replace_Element;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Reverse_Iterate is
new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
-- Start of processing for Reverse_Iterate
begin
Local_Reverse_Iterate (Container.Tree);
end Reverse_Iterate;
-----------
-- Right --
-----------
function Right (Node : Node_Access) return Node_Access is
begin
return Node.Right;
end Right;
---------------
-- Set_Color --
---------------
procedure Set_Color (Node : Node_Access; Color : Color_Type) is
begin
Node.Color := Color;
end Set_Color;
--------------
-- Set_Left --
--------------
procedure Set_Left (Node : Node_Access; Left : Node_Access) is
begin
Node.Left := Left;
end Set_Left;
----------------
-- Set_Parent --
----------------
procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
begin
Node.Parent := Parent;
end Set_Parent;
---------------
-- Set_Right --
---------------
procedure Set_Right (Node : Node_Access; Right : Node_Access) is
begin
Node.Right := Right;
end Set_Right;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
Process (Position.Node.Key.all, Position.Node.Element.all);
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map)
is
procedure Process (Node : Node_Access);
pragma Inline (Process);
procedure Iterate is
new Tree_Operations.Generic_Iteration (Process);
-------------
-- Process --
-------------
procedure Process (Node : Node_Access) is
begin
Key_Type'Output (Stream, Node.Key.all);
Element_Type'Output (Stream, Node.Element.all);
end Process;
-- Start of processing for Write
begin
Count_Type'Base'Write (Stream, Container.Tree.Length);
Iterate (Container.Tree);
end Write;
end Ada.Containers.Indefinite_Ordered_Maps;
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
[not found] ` <42F4B753.2080004@panathenaia.halfmoon.jp>
@ 2005-08-06 15:37 ` Matthew Heaney
2005-08-06 16:17 ` Y.Tomino
0 siblings, 1 reply; 7+ messages in thread
From: Matthew Heaney @ 2005-08-06 15:37 UTC (permalink / raw)
"Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
> I send a-ciorma.ad? as attachments.
> (C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.ads,
> C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.adb)
>
> I built gcc 4.0.1 with "--enable-languages=c,ada,c++ --prefix=/mingw".
You appear to have an older version of the sources. Here's the problem:
function Copy_Node (Source : Node_Access) return Node_Access is
Target : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Key => Source.Key,
Element => Source.Element);
begin
return Target;
end Copy_Node;
In this implementation of the indefinite container, keys and elements
are allocated. The code fragment above simply copies the pointers, but
this is wrong, since Adjust must make its own copy.
This is an old bug, that was fixed a few months ago. I'm surprised
you're seeing it. You can simply patch your copy like this:
function Copy_Node (Source : Node_Access) return Node_Access is
K : Key_Access := new Key_Type'(Source.Key.all);
E : Element_Access;
begin
E := new Element_Type'(Source.Element.all);
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Key => K,
Element => E);
exception
when others =>
Free_Key (K);
Free_Element (E);
raise;
end Copy_Node;
Alternatively you can grab a copy of that module from the repository at
<http://charles.tigris.org/> .
I would submit a bug report either to the FSF or to AdaCore, to ensure
the fix wends its way to public GCC repositories. This bug was found
and fixed in AdaCore's sources a while ago, so I don't understand why
you don't have the latest, corrected version.
-Matt
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
2005-08-06 15:37 ` Matthew Heaney
@ 2005-08-06 16:17 ` Y.Tomino
2005-08-06 16:33 ` Matthew Heaney
0 siblings, 1 reply; 7+ messages in thread
From: Y.Tomino @ 2005-08-06 16:17 UTC (permalink / raw)
Thanks!
But I think it's not reflected to FSF...
Matthew Heaney wrote:
>...
> This is an old bug, that was fixed a few months ago. I'm surprised
> you're seeing it. You can simply patch your copy like this:
I downloaded source of gcc 4.0.1 from one of mirrors:
http://mirrors.rcn.net/pub/sourceware/gcc/
>...
>I would submit a bug report either to the FSF or to AdaCore, to ensure
>the fix wends its way to public GCC repositories. This bug was found
>and fixed in AdaCore's sources a while ago, so I don't understand why
>you don't have the latest, corrected version.
Now, I downloaded the latest 4.1.0 snapshot from
http://mirrors.rcn.net/pub/sourceware/gcc/snapshots/4.1-20050730/
however, a-ciorse.abs's Copy_Node is
function Copy_Node (Source : Node_Access) return Node_Access is
Element : Element_Access := new Element_Type'(Source.Element.all);
begin
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Element => Element);
exception
when others =>
Free_Element (Element);
raise;
end Copy_Node;
It seems difference to your suggested code. There is not "Key".
> function Copy_Node (Source : Node_Access) return Node_Access is
> K : Key_Access := new Key_Type'(Source.Key.all);
> E : Element_Access;
> begin
> E := new Element_Type'(Source.Element.all);
>
> return new Node_Type'(Parent => null,
> Left => null,
> Right => null,
> Color => Source.Color,
> Key => K,
> Element => E);
> exception
> when others =>
> Free_Key (K);
> Free_Element (E);
> raise;
> end Copy_Node;
YT
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
2005-08-06 16:17 ` Y.Tomino
@ 2005-08-06 16:33 ` Matthew Heaney
2005-08-06 16:49 ` Y.Tomino
0 siblings, 1 reply; 7+ messages in thread
From: Matthew Heaney @ 2005-08-06 16:33 UTC (permalink / raw)
"Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
> Now, I downloaded the latest 4.1.0 snapshot from
> http://mirrors.rcn.net/pub/sourceware/gcc/snapshots/4.1-20050730/
> however, a-ciorse.abs's Copy_Node is...
>
> It seems difference to your suggested code. There is no "Key".
Yes, because it's a set, not a key. What about a-ciorma.adb?
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
2005-08-06 16:33 ` Matthew Heaney
@ 2005-08-06 16:49 ` Y.Tomino
0 siblings, 0 replies; 7+ messages in thread
From: Y.Tomino @ 2005-08-06 16:49 UTC (permalink / raw)
Matthew Heaney wrote:
> "Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
>
>
>>Now, I downloaded the latest 4.1.0 snapshot from
>>http://mirrors.rcn.net/pub/sourceware/gcc/snapshots/4.1-20050730/
>>however, a-ciorse.abs's Copy_Node is...
>>
>>It seems difference to your suggested code. There is no "Key".
>
>
> Yes, because it's a set, not a key. What about a-ciorma.adb?
Sorry. I mistook the file to see...
a-ciorma.adb's Copy_Node is corrected.
function Copy_Node (Source : Node_Access) return Node_Access is
K : Key_Access := new Key_Type'(Source.Key.all);
E : Element_Access;
begin
E := new Element_Type'(Source.Element.all);
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Key => K,
Element => E);
exception
when others =>
Free_Key (K);
Free_Element (E);
raise;
end Copy_Node;
I'm expecting the following release of gcc 4.1.0...
YT
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2005-08-06 16:49 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2005-08-06 11:57 Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ? Y.Tomino
2005-08-06 12:54 ` Matthew Heaney
2005-08-06 13:13 ` Y.Tomino
[not found] ` <42F4B753.2080004@panathenaia.halfmoon.jp>
2005-08-06 15:37 ` Matthew Heaney
2005-08-06 16:17 ` Y.Tomino
2005-08-06 16:33 ` Matthew Heaney
2005-08-06 16:49 ` Y.Tomino
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox