From 3a613a3621f796e5e8e21a6237caf60eaebcada0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 16:07:24 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Ed Schonberg * exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a container of a derived type. 2011-08-29 Hristian Kirtchev * impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb, s-finmas.ads: Revert previous change. 2011-08-29 Ed Schonberg * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads, a-ciorse.adb, a-ciorse.ads: Add iterator machinery to containers. From-SVN: r178237 --- gcc/ada/ChangeLog | 15 +++ gcc/ada/a-cidlli.adb | 125 ++++++++++++++++++++++++- gcc/ada/a-cidlli.ads | 75 +++++++++++++-- gcc/ada/a-cihama.adb | 92 ++++++++++++++++++- gcc/ada/a-cihama.ads | 72 +++++++++++++-- gcc/ada/a-ciorse.adb | 124 ++++++++++++++++++++++++- gcc/ada/a-ciorse.ads | 74 +++++++++++++-- gcc/ada/exp_ch4.adb | 2 - gcc/ada/exp_ch5.adb | 41 ++++++--- gcc/ada/impunit.adb | 2 + gcc/ada/s-finmas.adb | 150 ++++++------------------------ gcc/ada/s-finmas.ads | 25 +---- gcc/ada/s-stposu.adb | 214 +++---------------------------------------- gcc/ada/s-stposu.ads | 11 +-- 14 files changed, 636 insertions(+), 386 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 82b72fec4b1..1c72508894a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2011-08-29 Ed Schonberg + + * exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a + container of a derived type. + +2011-08-29 Hristian Kirtchev + + * impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb, + s-finmas.ads: Revert previous change. + +2011-08-29 Ed Schonberg + + * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads, + a-ciorse.adb, a-ciorse.ads: Add iterator machinery to containers. + 2011-08-29 Pascal Obry * exp_disp.adb: Minor comment fix. diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 8d1f8e36439..780efad4f41 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -35,6 +35,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + type Iterator is new + List_Iterator_Interfaces.Reversible_Iterator with record + Container : List_Access; + Node : Node_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + overriding function Next (Object : Iterator; Position : Cursor) + return Cursor; + overriding function Previous (Object : Iterator; Position : Cursor) + return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -431,6 +444,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Cursor'(Container'Unchecked_Access, Container.First); end First; + function First (Object : Iterator) return Cursor is + begin + return Cursor'(Object.Container, Object.Container.First); + end First; + ------------------- -- First_Element -- ------------------- @@ -820,6 +838,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is B := B - 1; end Iterate; + function Iterate (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + It : constant Iterator := (Container'Unchecked_Access, Container.First); + begin + return It; + end Iterate; + + function Iterate (Container : List; Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + It : constant Iterator := (Container'Unchecked_Access, Start.Node); + begin + return It; + end Iterate; + ---------- -- Last -- ---------- @@ -833,6 +867,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Cursor'(Container'Unchecked_Access, Container.Last); end Last; + function Last (Object : Iterator) return Cursor is + begin + if Object.Container.Last = null then + return No_Element; + end if; + + return Cursor'(Object.Container, Object.Container.Last); + end Last; + ------------------ -- Last_Element -- ------------------ @@ -910,6 +953,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end; end Next; + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Node = Object.Container.Last then + return No_Element; + + else + return (Object.Container, Position.Node.Next); + end if; + end Next; + ------------- -- Prepend -- ------------- @@ -951,6 +1004,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end; end Previous; + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Node = Position.Container.First then + return No_Element; + + else + return (Object.Container, Position.Node.Prev); + end if; + end Previous; + ------------------- -- Query_Element -- ------------------- @@ -1056,6 +1119,50 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is raise Program_Error with "attempt to stream list cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference (Container : List; Position : Cursor) + return Constant_Reference_Type is + begin + pragma Unreferenced (Container); + + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + + function Reference (Container : List; Position : Cursor) + return Reference_Type is + begin + pragma Unreferenced (Container); + + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => Position.Node.Element.all'Access); + end Reference; + --------------------- -- Replace_Element -- --------------------- @@ -1907,4 +2014,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is raise Program_Error with "attempt to stream list cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 7d572a8cc93..a6fd7106321 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -31,8 +31,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Iterator_Interfaces; +with Ada.Streams; use Ada.Streams; private with Ada.Finalization; -private with Ada.Streams; generic type Element_Type (<>) is private; @@ -44,7 +45,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Preelaborate; pragma Remote_Types; - type List is tagged private; + type List is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (List); type Cursor is private; @@ -53,6 +60,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Empty_List : constant List; No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package List_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); function "=" (Left, Right : List) return Boolean; @@ -170,8 +181,6 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - procedure Iterate (Container : List; Process : not null access procedure (Position : Cursor)); @@ -180,6 +189,54 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)); + function Iterate (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate (Container : List; Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : List; Position : Cursor) -- SHOULD BE ALIASED + return Constant_Reference_Type; + + function Reference + (Container : List; Position : Cursor) -- SHOULD BE ALIASED + return Reference_Type; + generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is @@ -220,12 +277,16 @@ private Lock : Natural := 0; end record; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + type Reference_Type + (Element : not null access Element_Type) is null record; + overriding procedure Adjust (Container : in out List); overriding procedure Finalize (Container : in out List) renames Clear; - use Ada.Streams; - procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out List); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index b487394b366..783fdf421b1 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -43,6 +43,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + type Iterator is new + Map_Iterator_Interfaces.Forward_Iterator with record + Container : Map_Access; + Node : Node_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Next (Object : Iterator; Position : Cursor) + return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -398,6 +408,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return Cursor'(Container'Unchecked_Access, Node); end First; + function First (Object : Iterator) return Cursor is + M : constant Map_Access := Object.Container; + N : constant Node_Access := HT_Ops.First (M.HT); + begin + if N = null then + return No_Element; + end if; + + return Cursor'(Object.Container.all'Unchecked_Access, N); + end First; + ---------- -- Free -- ---------- @@ -626,6 +647,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is B := B - 1; end Iterate; + function Iterate (Container : Map) + return Map_Iterator_Interfaces.Forward_Iterator'class + is + Node : constant Node_Access := HT_Ops.First (Container.HT); + It : constant Iterator := (Container'Unrestricted_Access, Node); + begin + return It; + end Iterate; + --------- -- Key -- --------- @@ -709,6 +739,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is end; end Next; + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + + else + return (Object.Container, Next (Position).Node); + end if; + end Next; + ------------------- -- Query_Element -- ------------------- @@ -784,6 +824,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Program_Error with "attempt to stream map cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + --------------- -- Read_Node -- --------------- @@ -814,6 +870,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return Node; end Read_Node; + --------------- + -- Reference -- + --------------- + + function Constant_Reference (Container : Map; Key : Key_Type) + return Constant_Reference_Type is + begin + return (Element => + Container.Find (Key).Node.Element.all'Unrestricted_Access); + end Constant_Reference; + + function Reference (Container : Map; Key : Key_Type) + return Reference_Type is + begin + return (Element => + Container.Find (Key).Node.Element.all'Unrestricted_Access); + end Reference; + ------------- -- Replace -- ------------- @@ -1064,6 +1138,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Program_Error with "attempt to stream map cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + ---------------- -- Write_Node -- ---------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 8a27c7e2619..2e089677112 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -32,8 +32,9 @@ ------------------------------------------------------------------------------ private with Ada.Containers.Hash_Tables; -private with Ada.Streams; private with Ada.Finalization; +with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Key_Type (<>) is private; @@ -47,7 +48,13 @@ package Ada.Containers.Indefinite_Hashed_Maps is pragma Preelaborate; pragma Remote_Types; - type Map is tagged private; + type Map is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Map); type Cursor is private; @@ -61,6 +68,12 @@ package Ada.Containers.Indefinite_Hashed_Maps is -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + overriding function "=" (Left, Right : Map) return Boolean; -- For each key/element pair in Left, equality attempts to find the key in -- Right; if a search fails the equality returns False. The search works by @@ -227,9 +240,6 @@ package Ada.Containers.Indefinite_Hashed_Maps is function Element (Container : Map; Key : Key_Type) return Element_Type; -- Equivalent to Element (Find (Container, Key)) - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - function Equivalent_Keys (Left, Right : Cursor) return Boolean; -- Returns the result of calling Equivalent_Keys with the keys of the nodes -- designated by cursors Left and Right. @@ -242,11 +252,54 @@ package Ada.Containers.Indefinite_Hashed_Maps is -- Returns the result of calling Equivalent_Keys with key Left and the node -- designated by Right. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED + return Constant_Reference_Type; + + function Reference (Container : Map; Key : Key_Type) + return Reference_Type; + procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); -- Calls Process for each node in the map + function Iterate (Container : Map) + return Map_Iterator_Interfaces.Forward_Iterator'class; + private pragma Inline ("="); pragma Inline (Length); @@ -283,7 +336,6 @@ private use HT_Types; use Ada.Finalization; - use Ada.Streams; overriding procedure Adjust (Container : in out Map); @@ -303,6 +355,12 @@ private for Cursor'Write use Write; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + type Reference_Type + (Element : not null access Element_Type) is null record; + procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out Cursor); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 7153c6dd235..7a782189708 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -40,6 +40,19 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Indefinite_Ordered_Sets is + type Iterator is new + Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record + Container : access constant Set; + Node : Node_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + overriding function Next (Object : Iterator; Position : Cursor) + return Cursor; + overriding function Previous (Object : Iterator; Position : Cursor) + return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -566,6 +579,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; + function First (Object : Iterator) return Cursor is + begin + return Cursor'( + Object.Container.all'Unrestricted_Access, Object.Container.Tree.First); + end First; + ------------------- -- First_Element -- ------------------- @@ -1190,6 +1209,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is B := B - 1; end Iterate; + function Iterate (Container : Set) + return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + is + It : constant Iterator := + (Container'Unchecked_Access, Container.Tree.First); + begin + return It; + end Iterate; + + function Iterate (Container : Set; Start : Cursor) + return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + is + It : constant Iterator := (Container'Unchecked_Access, Start.Node); + begin + return It; + end Iterate; + ---------- -- Last -- ---------- @@ -1203,6 +1239,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; + function Last (Object : Iterator) return Cursor is + begin + if Object.Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'( + Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last); + end Last; + ------------------ -- Last_Element -- ------------------ @@ -1281,6 +1327,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end; end Next; + function Next (Object : Iterator; Position : Cursor) + return Cursor + is + pragma Unreferenced (Object); + begin + return Next (Position); + end Next; + ------------- -- Overlap -- ------------- @@ -1334,6 +1388,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end; end Previous; + function Previous (Object : Iterator; Position : Cursor) + return Cursor + is + pragma Unreferenced (Object); + begin + return Previous (Position); + end Previous; + ------------------- -- Query_Element -- ------------------- @@ -1426,6 +1488,50 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "attempt to stream set cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference (Container : Set; Position : Cursor) + return Constant_Reference_Type + is + pragma Unreferenced (Container); + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => Position.Node.Element.all'Access); + end Constant_Reference; + + function Reference (Container : Set; Position : Cursor) + return Reference_Type + is + pragma Unreferenced (Container); + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => Position.Node.Element.all'Access); + end Reference; + ------------- -- Replace -- ------------- @@ -1758,4 +1864,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "attempt to stream set cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index 9d60bdcac89..3700c15e6b3 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -33,7 +33,8 @@ private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; -private with Ada.Streams; +with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Element_Type (<>) is private; @@ -47,7 +48,13 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - type Set is tagged private; + type Set is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Set); type Cursor is private; @@ -56,6 +63,52 @@ package Ada.Containers.Indefinite_Ordered_Sets is Empty_Set : constant Set; No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Ordered_Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + function Constant_Reference + (Container : Set; Position : Cursor) + return Constant_Reference_Type; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Reference + (Container : Set; Position : Cursor) + return Reference_Type; function "=" (Left, Right : Set) return Boolean; @@ -168,8 +221,6 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Contains (Container : Set; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - function "<" (Left, Right : Cursor) return Boolean; function ">" (Left, Right : Cursor) return Boolean; @@ -190,6 +241,12 @@ package Ada.Containers.Indefinite_Ordered_Sets is (Container : Set; Process : not null access procedure (Position : Cursor)); + function Iterate (Container : Set) + return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate (Container : Set; Start : Cursor) + return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + generic type Key_Type (<>) is private; @@ -271,7 +328,6 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; - use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -307,6 +363,12 @@ private for Set'Read use Read; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + type Reference_Type + (Element : not null access Element_Type) is null record; + Empty_Set : constant Set := (Controlled with Tree => (First => null, Last => null, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 4824df02583..8ac78ac1f5e 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1137,8 +1137,6 @@ package body Exp_Ch4 is Rewrite (Exp, New_Copy (Expression (Exp))); end if; else - Build_Allocate_Deallocate_Proc (N, True); - -- If we have: -- type A is access T1; -- X : A := new T2'(...); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 29399d790f8..4da232e5f9d 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2952,9 +2952,12 @@ package body Exp_Ch5 is if Of_Present (I_Spec) then declare - Default_Iter : constant Entity_Id := - Find_Aspect (Etype (Container), Aspect_Default_Iterator); - Ent : Entity_Id; + Default_Iter : constant Entity_Id := + Entity ( + Find_Aspect + (Etype (Container), Aspect_Default_Iterator)); + Container_Arg : Node_Id; + Ent : Entity_Id; begin Cursor := Make_Temporary (Loc, 'I'); @@ -2963,23 +2966,39 @@ package body Exp_Ch5 is null; else - Iter_Type := - Etype - (Find_Aspect - (Etype (Container), Aspect_Default_Iterator)); + Iter_Type := Etype (Default_Iter); -- Rewrite domain of iteration as a call to the default - -- iterator for the container type. + -- iterator for the container type. If the container is + -- a derived type and the aspect is inherited, convert + -- container to parent type. The Cursor type is also + -- inherited from the scope of the parent. + + if Base_Type (Etype (Container)) = + Base_Type (Etype (First_Formal (Default_Iter))) + then + Container_Arg := New_Copy_Tree (Container); + + else + Pack := Scope (Default_Iter); + + Container_Arg := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of ( + Etype (First_Formal (Default_Iter)), Loc), + Expression => New_Copy_Tree (Container)); + end if; Rewrite (Name (I_Spec), Make_Function_Call (Loc, - Name => Default_Iter, + Name => New_Occurrence_Of (Default_Iter, Loc), Parameter_Associations => - New_List (Relocate_Node (Name (I_Spec))))); + New_List (Container_Arg))); Analyze_And_Resolve (Name (I_Spec)); end if; - -- Find cursor type in container package. + -- Find cursor type in proper container package. Ent := First_Entity (Pack); while Present (Ent) loop diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 9aa86d523f6..ea636fe8b0a 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -346,6 +346,7 @@ package body Impunit is "s-addima", -- System.Address_Image "s-assert", -- System.Assertions + "s-finmas", -- System.Finalization_Masters "s-memory", -- System.Memory "s-parint", -- System.Partition_Interface "s-pooglo", -- System.Pool_Global @@ -528,6 +529,7 @@ package body Impunit is -- GNAT Defined Additions to Ada 20012 -- ----------------------------------------- + "s-spsufi", -- System.Storage_Pools.Subpools.Finalization "a-cofove", -- Ada.Containers.Formal_Vectors "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists "a-cforse", -- Ada.Containers.Formal_Ordered_Sets diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 4ab8a301b67..857db696b00 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -31,32 +31,12 @@ with Ada.Exceptions; use Ada.Exceptions; with System.Address_Image; -with System.HTable; use System.HTable; with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; package body System.Finalization_Masters is - -- Finalize_Address hash table types. In general, masters are homogeneous - -- collections of controlled objects. Rare cases such as allocations on a - -- subpool require heterogeneous masters. The following table provides a - -- relation between object address and its Finalize_Address routine. - - type Header_Num is range 0 .. 127; - - function Hash (Key : System.Address) return Header_Num; - - -- Address --> Finalize_Address_Ptr - - package Finalize_Address_Table is new Simple_HTable - (Header_Num => Header_Num, - Element => Finalize_Address_Ptr, - No_Element => null, - Key => System.Address, - Hash => Hash, - Equal => "="); - --------------------------- -- Add_Offset_To_Address -- --------------------------- @@ -99,17 +79,6 @@ package body System.Finalization_Masters is return Master.Base_Pool; end Base_Pool; - ----------------------------- - -- Delete_Finalize_Address -- - ----------------------------- - - procedure Delete_Finalize_Address (Obj : System.Address) is - begin - Lock_Task.all; - Finalize_Address_Table.Remove (Obj); - Unlock_Task.all; - end Delete_Finalize_Address; - ------------ -- Detach -- ------------ @@ -125,10 +94,10 @@ package body System.Finalization_Masters is N.Next := null; Unlock_Task.all; - - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. end if; + + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. end Detach; -------------- @@ -136,7 +105,6 @@ package body System.Finalization_Masters is -------------- overriding procedure Finalize (Master : in out Finalization_Master) is - Cleanup : Finalize_Address_Ptr; Curr_Ptr : FM_Node_Ptr; Ex_Occur : Exception_Occurrence; Obj_Addr : Address; @@ -176,41 +144,23 @@ package body System.Finalization_Masters is Detach (Curr_Ptr); - -- Skip the list header in order to offer proper object layout for - -- finalization. - - Obj_Addr := Curr_Ptr.all'Address + Header_Offset; - - -- Retrieve TSS primitive Finalize_Address depending on the master's - -- mode of operation. - - if Master.Is_Homogeneous then - Cleanup := Master.Finalize_Address; - else - Cleanup := Get_Finalize_Address (Obj_Addr); - end if; - - -- If Finalize_Address is not available, then this is most likely an - -- error in the expansion of the designated type or the allocator. - - pragma Assert (Cleanup /= null); + if Master.Finalize_Address /= null then - begin - Cleanup (Obj_Addr); + -- Skip the list header in order to offer proper object layout for + -- finalization and call Finalize_Address. - exception - when Fin_Occur : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Occur); - end if; - end; + Obj_Addr := Curr_Ptr.all'Address + Header_Offset; - -- When the master is a heterogeneous collection, destroy the object - -- - Finalize_Address pair since it is no longer needed. + begin + Master.Finalize_Address (Obj_Addr); - if not Master.Is_Homogeneous then - Delete_Finalize_Address (Obj_Addr); + exception + when Fin_Occur : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Occur); + end if; + end; end if; end loop; @@ -222,23 +172,6 @@ package body System.Finalization_Masters is end if; end Finalize; - -------------------------- - -- Get_Finalize_Address -- - -------------------------- - - function Get_Finalize_Address - (Obj : System.Address) return Finalize_Address_Ptr - is - Result : Finalize_Address_Ptr; - - begin - Lock_Task.all; - Result := Finalize_Address_Table.Get (Obj); - Unlock_Task.all; - - return Result; - end Get_Finalize_Address; - ----------------- -- Header_Size -- ----------------- @@ -248,17 +181,6 @@ package body System.Finalization_Masters is return FM_Node'Size / Storage_Unit; end Header_Size; - ---------- - -- Hash -- - ---------- - - function Hash (Key : System.Address) return Header_Num is - begin - return - Header_Num - (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); - end Hash; - ------------------- -- Header_Offset -- ------------------- @@ -280,11 +202,11 @@ package body System.Finalization_Masters is Master.Objects.Prev := Master.Objects'Unchecked_Access; end Initialize; - ------------------ - -- Print_Master -- - ------------------ + -------- + -- pm -- + -------- - procedure Print_Master (Master : Finalization_Master) is + procedure pm (Master : Finalization_Master) is Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; Head_Seen : Boolean := False; N_Ptr : FM_Node_Ptr; @@ -293,7 +215,6 @@ package body System.Finalization_Masters is -- Output the basic contents of a master -- Master : 0x123456789 - -- Is_Hmgen : TURE FALSE -- Base_Pool: null 0x123456789 -- Fin_Addr : null 0x123456789 -- Fin_Start: TRUE FALSE @@ -301,17 +222,16 @@ package body System.Finalization_Masters is Put ("Master : "); Put_Line (Address_Image (Master'Address)); - Put ("Is_Hmgen : "); - Put_Line (Master.Is_Homogeneous'Img); - Put ("Base_Pool: "); + if Master.Base_Pool = null then - Put_Line ("null"); + Put_Line (" null"); else Put_Line (Address_Image (Master.Base_Pool'Address)); end if; Put ("Fin_Addr : "); + if Master.Finalize_Address = null then Put_Line ("null"); else @@ -335,17 +255,17 @@ package body System.Finalization_Masters is -- Header - the address of the list header -- Prev - the address of the list header which the current element - -- points back to + -- - points back to -- Next - the address of the list header which the current element - -- points to + -- - points to -- (dummy head) - present if dummy head N_Ptr := Head; - while N_Ptr /= null loop -- Should never be null + while N_Ptr /= null loop -- Should never be null; we being defensive Put_Line ("V"); -- We see the head initially; we want to exit when we see the head a - -- second time. + -- SECOND time. if N_Ptr = Head then exit when Head_Seen; @@ -401,7 +321,7 @@ package body System.Finalization_Masters is N_Ptr := N_Ptr.Next; end loop; - end Print_Master; + end pm; ------------------- -- Set_Base_Pool -- @@ -427,18 +347,4 @@ package body System.Finalization_Masters is Master.Finalize_Address := Fin_Addr_Ptr; end Set_Finalize_Address; - -------------------------- - -- Set_Finalize_Address -- - -------------------------- - - procedure Set_Finalize_Address - (Obj : System.Address; - Fin_Addr_Ptr : Finalize_Address_Ptr) - is - begin - Lock_Task.all; - Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); - Unlock_Task.all; - end Set_Finalize_Address; - end System.Finalization_Masters; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index 6dd5e38fba7..87a607678bc 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -31,6 +31,7 @@ with Ada.Finalization; with Ada.Unchecked_Conversion; + with System.Storage_Elements; with System.Storage_Pools; @@ -68,10 +69,9 @@ package System.Finalization_Masters is -- Finalization master type structure. A unique master is associated with -- each access-to-controlled or access-to-class-wide type. Masters also act - -- as components of subpools. By default, a master contains objects of the - -- same designated type but it may also accomodate heterogeneous objects. + -- as components of subpools. - type Finalization_Master (Is_Homogeneous : Boolean := True) is + type Finalization_Master is new Ada.Finalization.Limited_Controlled with record Base_Pool : Any_Storage_Pool_Ptr := null; @@ -83,8 +83,7 @@ package System.Finalization_Masters is -- objects allocated in a [sub]pool. Finalize_Address : Finalize_Address_Ptr := null; - -- A reference to the routine reponsible for object finalization. This - -- is used only when the master is in homogeneous mode. + -- A reference to the routine reponsible for object finalization Finalization_Started : Boolean := False; pragma Atomic (Finalization_Started); @@ -115,10 +114,6 @@ package System.Finalization_Masters is -- Return a reference to the underlying storage pool on which the master -- operates. - procedure Delete_Finalize_Address (Obj : System.Address); - -- Destroy the relation pair object - Finalize_Address from the internal - -- hash table. - procedure Detach (N : not null FM_Node_Ptr); -- Remove a node from an arbitrary finalization master @@ -127,11 +122,6 @@ package System.Finalization_Masters is -- the list of allocated controlled objects, finalizing each one by calling -- its specific Finalize_Address. In the end, deallocate the dummy head. - function Get_Finalize_Address - (Obj : System.Address) return Finalize_Address_Ptr; - -- Retrieve the Finalize_Address primitive associated with a particular - -- object. - function Header_Offset return System.Storage_Elements.Storage_Offset; -- Return the size of type FM_Node as Storage_Offset @@ -141,7 +131,7 @@ package System.Finalization_Masters is overriding procedure Initialize (Master : in out Finalization_Master); -- Initialize the dummy head of a finalization master - procedure Print_Master (Master : Finalization_Master); + procedure pm (Master : Finalization_Master); -- Debug routine, outputs the contents of a master procedure Set_Base_Pool @@ -154,9 +144,4 @@ package System.Finalization_Masters is Fin_Addr_Ptr : Finalize_Address_Ptr); -- Set the clean up routine of a finalization master - procedure Set_Finalize_Address - (Obj : System.Address; - Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Add a relation pair object - Finalize_Address to the internal hash table - end System.Finalization_Masters; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 9a6c2310996..bf3a87e662f 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -31,19 +31,13 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Deallocation; -with System.Address_Image; + with System.Finalization_Masters; use System.Finalization_Masters; -with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; package body System.Storage_Pools.Subpools is - Finalize_Address_Table_In_Use : Boolean := False; - -- This flag should be set only when a successfull allocation on a subpool - -- has been performed and the associated Finalize_Address has been added to - -- the hash table in System.Finalization_Masters. - procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); -- Attach a subpool node to a pool @@ -254,40 +248,21 @@ package body System.Storage_Pools.Subpools is -- +- Header_And_Padding --+ N_Ptr := Address_To_FM_Node_Ptr - (N_Addr + Header_And_Padding - Header_Offset); + (N_Addr + Header_And_Padding - Header_Offset); -- Prepend the allocated object to the finalization master Attach (N_Ptr, Master.Objects'Unchecked_Access); + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Address; + end if; + -- Move the address from the hidden list header to the start of the -- object. This operation effectively hides the list header. Addr := N_Addr + Header_And_Padding; - -- Subpool allocations use heterogeneous masters to manage various - -- controlled objects. Associate a Finalize_Address with the object. - -- This relation pair is deleted when the object is deallocated or - -- when the associated master is finalized. - - if Is_Subpool_Allocation then - pragma Assert (not Master.Is_Homogeneous); - - Set_Finalize_Address (Addr, Fin_Address); - Finalize_Address_Table_In_Use := True; - - -- Normal allocations chain objects on homogeneous collections - - else - pragma Assert (Master.Is_Homogeneous); - - if Master.Finalize_Address = null then - Master.Finalize_Address := Fin_Address; - end if; - end if; - - -- Non-controlled allocation - else Addr := N_Addr; end if; @@ -340,13 +315,6 @@ package body System.Storage_Pools.Subpools is if Is_Controlled then - -- Destroy the relation pair object - Finalize_Address since it is no - -- longer needed. - - if Finalize_Address_Table_In_Use then - Delete_Finalize_Address (Addr); - end if; - -- Account for possible padding space before the header due to a -- larger alignment. @@ -414,8 +382,6 @@ package body System.Storage_Pools.Subpools is N.Prev.Next := N.Next; N.Next.Prev := N.Prev; - N.Prev := null; - N.Next := null; Unlock_Task.all; @@ -439,22 +405,9 @@ package body System.Storage_Pools.Subpools is procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is Curr_Ptr : SP_Node_Ptr; Ex_Occur : Exception_Occurrence; + Next_Ptr : SP_Node_Ptr; Raised : Boolean := False; - function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean; - -- Determine whether a list contains only one element, the dummy head - - ------------------- - -- Is_Empty_List -- - ------------------- - - function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is - begin - return L.Next = L and then L.Prev = L; - end Is_Empty_List; - - -- Start of processing for Finalize_Pool - begin -- It is possible for multiple tasks to cause the finalization of a -- common pool. Allow only one task to finalize the contents. @@ -470,8 +423,11 @@ package body System.Storage_Pools.Subpools is Pool.Finalization_Started := True; - while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop - Curr_Ptr := Pool.Subpools.Next; + -- Skip the dummy head + + Curr_Ptr := Pool.Subpools.Next; + while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop + Next_Ptr := Curr_Ptr.Next; -- Perform the following actions: @@ -490,6 +446,8 @@ package body System.Storage_Pools.Subpools is Save_Occurrence (Ex_Occur, Fin_Occur); end if; end; + + Curr_Ptr := Next_Ptr; end loop; -- If the finalization of a particular master failed, reraise the @@ -579,150 +537,6 @@ package body System.Storage_Pools.Subpools is return Subpool.Owner; end Pool_Of_Subpool; - ---------------- - -- Print_Pool -- - ---------------- - - procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is - Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access; - Head_Seen : Boolean := False; - SP_Ptr : SP_Node_Ptr; - - begin - -- Output the contents of the pool - - -- Pool : 0x123456789 - -- Subpools : 0x123456789 - -- Fin_Start : TRUE FALSE - -- Controller: OK NOK - - Put ("Pool : "); - Put_Line (Address_Image (Pool'Address)); - - Put ("Subpools : "); - Put_Line (Address_Image (Pool.Subpools'Address)); - - Put ("Fin_Start : "); - Put_Line (Pool.Finalization_Started'Img); - - Put ("Controlled: "); - if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then - Put_Line ("OK"); - else - Put_Line ("NOK (ERROR)"); - end if; - - SP_Ptr := Head; - while SP_Ptr /= null loop -- Should never be null - Put_Line ("V"); - - -- We see the head initially; we want to exit when we see the head a - -- second time. - - if SP_Ptr = Head then - exit when Head_Seen; - - Head_Seen := True; - end if; - - -- The current element is null. This should never happend since the - -- list is circular. - - if SP_Ptr.Prev = null then - Put_Line ("null (ERROR)"); - - -- The current element points back to the correct element - - elsif SP_Ptr.Prev.Next = SP_Ptr then - Put_Line ("^"); - - -- The current element points to an erroneous element - - else - Put_Line ("? (ERROR)"); - end if; - - -- Output the contents of the node - - Put ("|Header: "); - Put (Address_Image (SP_Ptr.all'Address)); - if SP_Ptr = Head then - Put_Line (" (dummy head)"); - else - Put_Line (""); - end if; - - Put ("| Prev: "); - - if SP_Ptr.Prev = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Prev.all'Address)); - end if; - - Put ("| Next: "); - - if SP_Ptr.Next = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Next.all'Address)); - end if; - - Put ("| Subp: "); - - if SP_Ptr.Subpool = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Subpool.all'Address)); - end if; - - SP_Ptr := SP_Ptr.Next; - end loop; - end Print_Pool; - - ------------------- - -- Print_Subpool -- - ------------------- - - procedure Print_Subpool (Subpool : Subpool_Handle) is - begin - if Subpool = null then - Put_Line ("null"); - return; - end if; - - -- Output the contents of a subpool - - -- Owner : 0x123456789 - -- Master: 0x123456789 - -- Node : 0x123456789 - - Put ("Owner : "); - if Subpool.Owner = null then - Put_Line ("null"); - else - Put_Line (Address_Image (Subpool.Owner'Address)); - end if; - - Put ("Master: "); - Put_Line (Address_Image (Subpool.Master'Address)); - - Put ("Node : "); - if Subpool.Node = null then - Put ("null"); - - if Subpool.Owner = null then - Put_Line (" OK"); - else - Put_Line (" (ERROR)"); - end if; - else - Put_Line (Address_Image (Subpool.Node'Address)); - end if; - - Print_Master (Subpool.Master); - end Print_Subpool; - ------------------------- -- Set_Pool_Of_Subpool -- ------------------------- diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads index 79ff97cfdce..bd268186926 100644 --- a/gcc/ada/s-stposu.ads +++ b/gcc/ada/s-stposu.ads @@ -34,6 +34,7 @@ ------------------------------------------------------------------------------ with Ada.Finalization; + with System.Finalization_Masters; with System.Storage_Elements; @@ -240,8 +241,8 @@ private Owner : Any_Storage_Pool_With_Subpools_Ptr := null; -- A reference to the master pool_with_subpools - Master : aliased System.Finalization_Masters.Finalization_Master (False); - -- A heterogeneous collection of controlled objects + Master : aliased System.Finalization_Masters.Finalization_Master; + -- A collection of controlled objects Node : SP_Node_Ptr := null; -- A link to the doubly linked list node which contains the subpool. @@ -335,10 +336,4 @@ private procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools); -- Setup the doubly linked list of subpools - procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools); - -- Debug routine, output the contents of a pool_with_subpools - - procedure Print_Subpool (Subpool : Subpool_Handle); - -- Debug routine, output the contents of a subpool - end System.Storage_Pools.Subpools; -- 2.30.2