diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-11-23 13:51:23 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-11-23 13:51:23 +0000 |
commit | 212a85cbd8f302065907a06dd61362d14c41aa37 (patch) | |
tree | 267a728ee3a7d34623bc37b747312a45db885308 /gcc/ada | |
parent | 1d7479f66e96e089d61873262d5041e9f09bb059 (diff) | |
download | gcc-212a85cbd8f302065907a06dd61362d14c41aa37.tar.gz |
2011-11-23 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Freeze_All_Ent): An incomplete type is not
frozen by a subprogram body that does not come from source.
2011-11-23 Pascal Obry <obry@adacore.com>
* s-oscons-tmplt.c: Add PTY_Library constant. It contains
the library for pseudo terminal support.
* g-exptty.ads: Add pseudo-terminal library into a Linker_Options
pragma.
2011-11-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch9.adb: No check on entry family index if generic.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* sem_ch9.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-irix.adb,
s-taprop-posix.adb, s-taprop-rtx.adb, s-taprop-solaris.adb,
s-taprop-tru64.adb, s-taprop-vxworks.adb: Move dependency on
System.OS_Constants from shared spec of
System.Tasking.Primitive_Operations to the specific body variants
that really require this dependency.
2011-11-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Analyze_Subprogram_Renaming_Declaration):
If the declaration has aspects, analyze them so they can be
properly rejected.
2011-11-23 Hristian Kirtchev <kirtchev@adacore.com>
* a-comutr.adb, a-coorma.adb, a-coorse.adb, a-convec.adb, a-cihase.adb,
a-cimutr.adb, a-coinve.adb, a-ciorma.adb, a-ciorse.adb, a-cobove.adb,
a-cohama.adb, a-cihama.adb, a-cidlli.adb, a-cdlili.adb, a-cbhama.adb,
a-cbhase.adb, a-cbmutr.adb, a-cborma.adb, a-cborse.adb, a-cbdlli.adb:
Add with and use clause for Ada.Finalization. Type
Iterator and Child_Iterator are now derived from Limited_Controlled.
(Finalize): New routine.
(Iterate): Add a renaming of counter Busy and
increment it. Update the return aggregate.
(Iterate_Children): Add a renaming of
counter Busy and increment it. Update the return aggregate.
(Iterate_Subtree): Add a renaming of counter Busy and increment
it. Update the return aggregate.
* a-cdlili.ads, a-cidlli.ads: Type List_Access is now a general access
type.
* a-cihama.ads: Type Map_Access is now a general access type.
* a-comutr.ads, a-cimutr.ads: Use type Natural for the two locks
associated with the tree.
* a-cohama.ads: Type Map_Access is now a general access type.
* a-coinve.ads, a-convec.ads: Type Vector_Access is now a general
access type.
* exp_ch5.adb (Expand_Iterator_Loop): Do not create a block
to wrap the loop as this is done at an earlier step, during
analysis. The declarations of the iterator and the cursor use
the usual Insert_Action mechanism when added into the tree.
* sem_ch5.adb (Analyze_Loop_Statement): Remove local constant
Loop_Statement and replace all respective uses by N. Add local
constant Loc. Preanalyze the loop iterator to discover whether
it is a container iterator and if it is, wrap the loop in a
block. This ensures that any controlled temporaries produced
by the iteration scheme share the same lifetime of the loop.
(Is_Container_Iterator): New routine.
(Is_Wrapped_In_Block): New routine.
(Pre_Analyze_Range): Move spec and body to the library level.
2011-11-23 Sergey Rybin <rybin@adacore.com frybin>
* gnat_ugn.texi, vms_data.ads: Add documentation for new gnatpp option
that controls casing of type and subtype names.
2011-11-23 Yannick Moy <moy@adacore.com>
* sem_ch3.adb: Minor addition of comments.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* prj-part.adb (Extension_Withs): New global variable,
contains the head of the list of WITH clauses from the EXTENDS
ALL projects for which virtual packages are being created.
(Look_For_Virtual_Projects_For): When recursing through
an EXTENDS ALL, add the WITH clauses of the extending
project to Extension_Withs. When adding a project to the
Virtual_Hash, record the associated Extension_Withs list.
(Create_Virtual_Extending_Project): Add a copy of the appropriate
Extension_Withs to the virtual project.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* mlib-tgt-specific-vxworks.adb: Minor reformatting.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* Make-generated.in (Sdefault.Target_Name): Set to
$(target_noncanonical) instead of $(target) for consistency.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@181668 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
47 files changed, 1501 insertions, 462 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b462d0a14f1..56b2a1ee78b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,101 @@ +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_All_Ent): An incomplete type is not + frozen by a subprogram body that does not come from source. + +2011-11-23 Pascal Obry <obry@adacore.com> + + * s-oscons-tmplt.c: Add PTY_Library constant. It contains + the library for pseudo terminal support. + * g-exptty.ads: Add pseudo-terminal library into a Linker_Options + pragma. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch9.adb: No check on entry family index if generic. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * sem_ch9.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-irix.adb, + s-taprop-posix.adb, s-taprop-rtx.adb, s-taprop-solaris.adb, + s-taprop-tru64.adb, s-taprop-vxworks.adb: Move dependency on + System.OS_Constants from shared spec of + System.Tasking.Primitive_Operations to the specific body variants + that really require this dependency. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming_Declaration): + If the declaration has aspects, analyze them so they can be + properly rejected. + +2011-11-23 Hristian Kirtchev <kirtchev@adacore.com> + + * a-comutr.adb, a-coorma.adb, a-coorse.adb, a-convec.adb, a-cihase.adb, + a-cimutr.adb, a-coinve.adb, a-ciorma.adb, a-ciorse.adb, a-cobove.adb, + a-cohama.adb, a-cihama.adb, a-cidlli.adb, a-cdlili.adb, a-cbhama.adb, + a-cbhase.adb, a-cbmutr.adb, a-cborma.adb, a-cborse.adb, a-cbdlli.adb: + Add with and use clause for Ada.Finalization. Type + Iterator and Child_Iterator are now derived from Limited_Controlled. + (Finalize): New routine. + (Iterate): Add a renaming of counter Busy and + increment it. Update the return aggregate. + (Iterate_Children): Add a renaming of + counter Busy and increment it. Update the return aggregate. + (Iterate_Subtree): Add a renaming of counter Busy and increment + it. Update the return aggregate. + * a-cdlili.ads, a-cidlli.ads: Type List_Access is now a general access + type. + * a-cihama.ads: Type Map_Access is now a general access type. + * a-comutr.ads, a-cimutr.ads: Use type Natural for the two locks + associated with the tree. + * a-cohama.ads: Type Map_Access is now a general access type. + * a-coinve.ads, a-convec.ads: Type Vector_Access is now a general + access type. + * exp_ch5.adb (Expand_Iterator_Loop): Do not create a block + to wrap the loop as this is done at an earlier step, during + analysis. The declarations of the iterator and the cursor use + the usual Insert_Action mechanism when added into the tree. + * sem_ch5.adb (Analyze_Loop_Statement): Remove local constant + Loop_Statement and replace all respective uses by N. Add local + constant Loc. Preanalyze the loop iterator to discover whether + it is a container iterator and if it is, wrap the loop in a + block. This ensures that any controlled temporaries produced + by the iteration scheme share the same lifetime of the loop. + (Is_Container_Iterator): New routine. + (Is_Wrapped_In_Block): New routine. + (Pre_Analyze_Range): Move spec and body to the library level. + +2011-11-23 Sergey Rybin <rybin@adacore.com frybin> + + * gnat_ugn.texi, vms_data.ads: Add documentation for new gnatpp option + that controls casing of type and subtype names. + +2011-11-23 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb: Minor addition of comments. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * prj-part.adb (Extension_Withs): New global variable, + contains the head of the list of WITH clauses from the EXTENDS + ALL projects for which virtual packages are being created. + (Look_For_Virtual_Projects_For): When recursing through + an EXTENDS ALL, add the WITH clauses of the extending + project to Extension_Withs. When adding a project to the + Virtual_Hash, record the associated Extension_Withs list. + (Create_Virtual_Extending_Project): Add a copy of the appropriate + Extension_Withs to the virtual project. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * mlib-tgt-specific-vxworks.adb: Minor reformatting. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * Make-generated.in (Sdefault.Target_Name): Set to + $(target_noncanonical) instead of $(target) for consistency. + 2011-11-23 Matthew Heaney <heaney@adacore.com> * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Iterator): Declared diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 85ead8aef0c..22000b3c7e4 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -27,16 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Count_Type; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Count_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -494,6 +498,22 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return Position.Container.Nodes (Position.Node).Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1064,9 +1084,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Count_Type := Container.First; begin @@ -1091,6 +1109,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1102,7 +1122,13 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1110,6 +1136,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1143,7 +1171,13 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index a87db6addfb..471193079b5 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -34,14 +34,18 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Maps is - type Iterator is new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -392,6 +396,22 @@ package body Ada.Containers.Bounded_Hashed_Maps is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -649,7 +669,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -670,8 +690,15 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 1de29ab1a7e..cfefc73b6c1 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -34,15 +34,20 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Sets is - type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record Container : Set_Access; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -569,6 +574,22 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -887,7 +908,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -906,9 +927,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access); end Iterate; ------------ @@ -1600,7 +1628,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin if Node = 0 then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Container.Nodes (Node).Element; diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 7ad2de4e62a..acda30f63c6 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -27,30 +27,38 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; + package body Ada.Containers.Bounded_Multiway_Trees is No_Node : constant Count_Type'Base := -1; - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next @@ -1229,6 +1237,34 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Subtree => Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1732,8 +1768,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin if Container.Count = 0 then @@ -1758,13 +1793,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1786,9 +1827,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; declare - NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Count_Type; + NN : Tree_Node_Array renames Parent.Container.Nodes; begin B := B + 1; @@ -1836,9 +1877,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1849,8 +1897,17 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1869,7 +1926,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all; - B : Integer renames T.Busy; + B : Natural renames T.Busy; begin B := B + 1; @@ -2259,8 +2316,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2529,7 +2586,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Count_Type; begin @@ -3209,8 +3266,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index 940d6efa9cb..141350956c1 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -35,19 +35,22 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Count_Type; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -551,6 +554,22 @@ package body Ada.Containers.Bounded_Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -900,6 +919,8 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -911,7 +932,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Container.First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -919,9 +946,10 @@ package body Ada.Containers.Bounded_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - begin + B : Natural renames Container'Unrestricted_Access.all.Busy; - -- iterator was defined to behave the same as for a complete iterator, + begin + -- Iterator was defined to behave the same as for a complete iterator, -- and iterate over the entire sequence of items. However, those -- semantics were unintuitive and arguably error-prone (it is too easy -- to accidentally create an endless loop), and so they were changed, @@ -953,7 +981,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration.) - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index 62ab5f21470..17fa7950237 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -38,19 +38,22 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Count_Type; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -568,6 +571,22 @@ package body Ada.Containers.Bounded_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1221,8 +1240,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1234,12 +1255,20 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1274,7 +1303,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration.) - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 63cae28aefe..12242583ebe 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -27,18 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; - with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Doubly_Linked_Lists is - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -396,6 +398,22 @@ package body Ada.Containers.Doubly_Linked_Lists is return Position.Node.Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -422,7 +440,7 @@ package body Ada.Containers.Doubly_Linked_Lists is while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -441,7 +459,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -857,9 +875,7 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -867,7 +883,7 @@ package body Ada.Containers.Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -882,6 +898,8 @@ package body Ada.Containers.Doubly_Linked_Lists is function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -893,12 +911,20 @@ package body Ada.Containers.Doubly_Linked_Lists is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : List; Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -932,7 +958,13 @@ package body Ada.Containers.Doubly_Linked_Lists is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -945,7 +977,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1412,7 +1444,7 @@ package body Ada.Containers.Doubly_Linked_Lists is while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1439,7 +1471,7 @@ package body Ada.Containers.Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 2de03e520aa..0e6437602f5 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -306,7 +306,7 @@ private for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 764325e4bdc..b74e8e115e4 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -27,23 +27,25 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -429,6 +431,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Position.Node.Element.all; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -459,7 +477,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -478,7 +496,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -884,9 +902,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -894,7 +910,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -908,8 +924,10 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class + return List_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -921,7 +939,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -929,6 +953,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -962,7 +988,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -975,7 +1007,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1452,7 +1484,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1479,7 +1511,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; exception diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index c40ad30b155..be1b4344a8a 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -309,7 +309,7 @@ private for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 84bbdfdf327..e9b9cc05d91 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -34,7 +34,6 @@ with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Maps is @@ -45,10 +44,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is limited new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -421,6 +423,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -433,7 +447,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -471,7 +485,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is @@ -687,10 +701,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing Iterate @@ -711,8 +725,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 7c67c315583..3b639f4cff7 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -341,11 +341,10 @@ private use HT_Types; use Ada.Finalization; - overriding procedure Adjust (Container : in out Map); - + overriding procedure Adjust (Container : in out Map); overriding procedure Finalize (Container : in out Map); - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 22c5890cea6..3a93f91f5c2 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -36,15 +36,17 @@ with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Containers.Prime_Numbers; - -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Forward_Iterator with record - Container : Set_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -569,6 +571,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -988,7 +1002,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -1007,9 +1021,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; ------------ @@ -1897,7 +1919,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; Free (X); @@ -1915,7 +1937,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Node = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element.all; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 2fdc8a75469..9e211ad156a 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -28,35 +28,41 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Previous - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Last (Object : Child_Iterator) return Cursor; @@ -925,6 +931,34 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1304,8 +1338,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1326,13 +1359,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1349,7 +1388,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1396,9 +1435,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1409,8 +1455,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1423,7 +1478,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1789,8 +1844,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2052,7 +2107,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2555,8 +2610,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 29be8ca39ea..6d5684d1b35 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -327,8 +327,8 @@ private type Tree is new Controlled with record Root : aliased Tree_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index ea8fa75636b..3aa3c17e1c1 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -40,15 +40,17 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Maps is pragma Suppress (All_Checks); - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -535,6 +537,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -857,7 +875,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; -- Start of processing for Iterate @@ -878,6 +896,8 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -889,7 +909,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -897,6 +923,8 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -931,7 +959,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 0d3af93f6d8..4d0f3dcbd6a 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -37,20 +37,21 @@ with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -571,6 +572,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1254,7 +1271,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1275,8 +1292,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1288,14 +1307,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1330,7 +1357,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index e78e3ce12d3..e570f828bb1 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -28,16 +28,19 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; - +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Vectors is - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record - Container : Vector_Access; - Index : Index_Type; - end record; + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -658,6 +661,22 @@ package body Ada.Containers.Bounded_Vectors is end if; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1607,8 +1626,7 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1630,8 +1648,16 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Index_Type'First); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1639,8 +1665,16 @@ package body Ada.Containers.Bounded_Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Start.Index); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 634ccc0f862..8c92a303076 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -39,10 +39,13 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -385,6 +388,18 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -397,7 +412,7 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -435,7 +450,7 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is @@ -546,7 +561,7 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -588,7 +603,7 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -638,10 +653,10 @@ package body Ada.Containers.Hashed_Maps is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -662,8 +677,15 @@ package body Ada.Containers.Hashed_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 5f01994e8ad..93c3504e8d5 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -384,7 +384,7 @@ private for Map'Read use Read; - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index e35f2f781de..02a3c53e3f2 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -29,7 +29,7 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is @@ -39,15 +39,17 @@ package body Ada.Containers.Indefinite_Vectors is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record Container : Vector_Access; Index : Index_Type; end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -1105,6 +1107,18 @@ package body Ada.Containers.Indefinite_Vectors is end; end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1129,7 +1143,7 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Elements.EA (J) /= null and then Container.Elements.EA (J).all = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -1167,7 +1181,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is @@ -1982,7 +1996,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2018,7 +2032,8 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= + Vector_Access'(Container'Unrestricted_Access) then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2029,7 +2044,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2051,7 +2066,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2064,7 +2079,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2101,7 +2116,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2112,7 +2127,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2134,7 +2149,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; ------------------ @@ -2465,7 +2480,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2476,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2498,7 +2513,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert_Space (Container, Index, Count); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2518,15 +2533,14 @@ package body Ada.Containers.Indefinite_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2540,9 +2554,16 @@ package body Ada.Containers.Indefinite_Vectors is function Iterate (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2550,10 +2571,16 @@ package body Ada.Containers.Indefinite_Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2566,7 +2593,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -3313,7 +3340,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -3330,7 +3357,7 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -3376,7 +3403,7 @@ package body Ada.Containers.Indefinite_Vectors is begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3491,7 +3518,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Index); + return Cursor'(Container'Unrestricted_Access, Index); end To_Cursor; -------------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 06568278997..85d68ebf7ee 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -426,7 +426,7 @@ private for Vector'Read use Read; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index 86be79ffc35..e78aaccf957 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -29,28 +29,34 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next (Object : Child_Iterator; @@ -898,6 +904,34 @@ package body Ada.Containers.Multiway_Trees is return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1342,8 +1376,7 @@ package body Ada.Containers.Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1364,13 +1397,19 @@ package body Ada.Containers.Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1387,7 +1426,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1434,9 +1473,16 @@ package body Ada.Containers.Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1447,8 +1493,17 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1461,7 +1516,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1807,8 +1862,8 @@ package body Ada.Containers.Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2060,7 +2115,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2578,8 +2633,8 @@ package body Ada.Containers.Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index b035e1637fe..37e2eda0c2c 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -372,8 +372,8 @@ private type Tree is new Controlled with record Root : aliased Root_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 79071810182..a94f11c9f93 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -29,7 +29,6 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Vectors is @@ -37,12 +36,15 @@ package body Ada.Containers.Vectors is procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with record Container : Vector_Access; Index : Index_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; overriding function Next @@ -778,6 +780,18 @@ package body Ada.Containers.Vectors is Free (X); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -800,7 +814,7 @@ package body Ada.Containers.Vectors is for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -835,7 +849,7 @@ package body Ada.Containers.Vectors is if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end if; end First; @@ -1500,7 +1514,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1536,7 +1550,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1547,7 +1561,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1569,7 +1583,7 @@ package body Ada.Containers.Vectors is Insert (Container, Index, New_Item); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -1582,7 +1596,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1619,7 +1633,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1630,7 +1644,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1652,7 +1666,7 @@ package body Ada.Containers.Vectors is Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2036,7 +2050,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2047,7 +2061,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2069,7 +2083,7 @@ package body Ada.Containers.Vectors is Insert_Space (Container, Index, Count => Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2089,15 +2103,14 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2112,9 +2125,16 @@ package body Ada.Containers.Vectors is (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2122,9 +2142,16 @@ package body Ada.Containers.Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2136,7 +2163,7 @@ package body Ada.Containers.Vectors is if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end if; end Last; @@ -2903,7 +2930,7 @@ package body Ada.Containers.Vectors is begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -2915,7 +2942,7 @@ package body Ada.Containers.Vectors is for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -2960,7 +2987,7 @@ package body Ada.Containers.Vectors is begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3061,7 +3088,7 @@ package body Ada.Containers.Vectors is if Index not in Index_Type'First .. Container.Last then return No_Element; else - return (Container'Unchecked_Access, Index); + return (Container'Unrestricted_Access, Index); end if; end To_Cursor; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 9eb82c791fe..00f9b2abbac 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -410,7 +410,7 @@ private Lock : Natural := 0; end record; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index d5f5391d871..778d223e291 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -39,15 +39,17 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -488,6 +490,22 @@ package body Ada.Containers.Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -839,6 +857,8 @@ package body Ada.Containers.Ordered_Maps is function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -850,12 +870,20 @@ package body Ada.Containers.Ordered_Maps is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Map; Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -890,7 +918,13 @@ package body Ada.Containers.Ordered_Maps is -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index ce004e2d737..b4518f40b75 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -42,15 +42,17 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -512,6 +514,22 @@ package body Ada.Containers.Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1160,7 +1178,7 @@ package body Ada.Containers.Ordered_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1182,6 +1200,8 @@ package body Ada.Containers.Ordered_Sets is function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1193,12 +1213,19 @@ package body Ada.Containers.Ordered_Sets is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null); end Iterate; function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1233,7 +1260,12 @@ package body Ada.Containers.Ordered_Sets is -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node); end Iterate; ---------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 772faa93216..d7f30991fca 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3233,7 +3233,7 @@ package body Exp_Ch5 is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Pack, Loc), Selector_Name => - Make_Identifier (Loc, Name_Has_Element)), + Make_Identifier (Loc, Name_Has_Element)), Parameter_Associations => New_List ( @@ -3250,21 +3250,19 @@ package body Exp_Ch5 is -- I : Iterator_Type renames Container; -- C : Pack.Cursor_Type := Container.[First | Last]; - declare - Decl1 : Node_Id; - Decl2 : Node_Id; - Decl3 : Node_Id; + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Iterator, + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec)))); - begin - Decl1 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Iterator, - Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), - Name => Relocate_Node (Name (I_Spec))); + -- Create declaration for cursor - -- Create declaration for cursor + declare + Decl : Node_Id; - Decl2 := + begin + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Cursor, Object_Definition => @@ -3275,31 +3273,14 @@ package body Exp_Ch5 is Selector_Name => Make_Identifier (Loc, Name_Init))); - Set_Assignment_OK (Decl2); - -- The cursor is only modified in expanded code, so it appears -- as unassigned to the warning machinery. We must suppress -- this spurious warning explicitly. - Decl3 := - Make_Pragma (Loc, - Chars => Name_Warnings, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Off)), - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Cursor, Loc)))); + Set_Warnings_Off (Cursor); + Set_Assignment_OK (Decl); - -- The expanded loop is wrapped in a block, to make the loop - -- variable local. - - New_Loop := - Make_Block_Statement (Loc, - Declarations => New_List (Decl1, Decl2, Decl3), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (New_Loop))); + Insert_Action (N, Decl); end; -- If the range of iteration is given by a function call that diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d9759843b72..16521f9f6d7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1342,7 +1342,9 @@ package body Freeze is -- If an incomplete type is still not frozen, this may be a -- premature freezing because of a body declaration that follows. - -- Indicate where the freezing took place. + -- Indicate where the freezing took place. Freezing will happen + -- if the body comes from source, but not if it is internally + -- generated, for example as the body of a type invariant. -- If the freezing is caused by the end of the current declarative -- part, it is a Taft Amendment type, and there is no error. @@ -1360,8 +1362,9 @@ package body Freeze is N_Protected_Body, N_Task_Body) or else Nkind (Bod) in N_Body_Stub) - and then - List_Containing (After) = List_Containing (Parent (E)) + and then + List_Containing (After) = List_Containing (Parent (E)) + and then Comes_From_Source (Bod) then Error_Msg_Sloc := Sloc (Next (After)); Error_Msg_NE diff --git a/gcc/ada/g-exptty.ads b/gcc/ada/g-exptty.ads index 878f784fc6a..e218e0b5d54 100644 --- a/gcc/ada/g-exptty.ads +++ b/gcc/ada/g-exptty.ads @@ -32,9 +32,12 @@ with GNAT.TTY; with System; +with System.OS_Constants; package GNAT.Expect.TTY is + pragma Linker_Options (System.OS_Constants.PTY_Library); + ------------------ -- TTY_Process -- ------------------ diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 266aa7d8f15..ba5737a487e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -13188,6 +13188,23 @@ setting. Enumeration literals are in mixed case. Overrides ^-n^/NAME_CASING^ casing setting. +@cindex @option{^-nt@var{x}^/TYPE_CASING^} (@command{gnatpp}) +@item ^-neD^/TYPE_CASING=AS_DECLARED^ +Type and subtype name casing for defining occurrences are as they appear in +the source file. Overrides ^-n^/NAME_CASING^ casing setting. + +@item ^-ntU^/TYPE_CASING=UPPER_CASE^ +Type and subtype names are in upper case. Overrides ^-n^/NAME_CASING^ casing +setting. + +@item ^-ntL^/TYPE_CASING=LOWER_CASE^ +Type and subtype names are in lower case. Overrides ^-n^/NAME_CASING^ casing +setting. + +@item ^-ntM^/TYPE_CASING=MIXED_CASE^ +Type and subtype names are in mixed case. Overrides ^-n^/NAME_CASING^ casing +setting. + @cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) @item ^-pL^/PRAGMA_CASING=LOWER_CASE^ Pragma names are lower case diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 022efe3c80b..23ad841a3c5 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -99,12 +99,15 @@ package body Prj.Part is package Virtual_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, - No_Element => Empty_Node, + No_Element => Project_Node_High_Bound, Key => Project_Node_Id, Hash => Prj.Tree.Hash, Equal => "="); - -- Hash table to store the node id of the project for which a virtual - -- extending project need to be created. + -- Hash table to store the node ids of projects for which a virtual + -- extending project need to be created. The corresponding value is the + -- head of a list of WITH clauses corresponding to the context of the + -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_ + -- High_Bound because we want Empty_Node to be a possible value. package Processed_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -148,11 +151,13 @@ package body Prj.Part is -- Check that an aggregate project only imports abstract projects procedure Create_Virtual_Extending_Project - (For_Project : Project_Node_Id; - Main_Project : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref); + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + Extension_Withs : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); -- Create a virtual extending project of For_Project. Main_Project is - -- the extending all project. + -- the extending all project. Extension_Withs is the head of a WITH clause + -- list to be added to the created virtual project. -- -- The String_Value_Of is not set for the automatically added with -- clause and keeps the default value of No_Name. This enables Prj.PP @@ -236,14 +241,45 @@ package body Prj.Part is -- Returns No_Name if the path name is invalid, because the corresponding -- project name does not have the syntax of an ada identifier. + function Copy_With_Clause + (With_Clause : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Next_Clause : Project_Node_Id) return Project_Node_Id; + -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the + -- indicated one. + + ---------------------- + -- Copy_With_Clause -- + ---------------------- + + function Copy_With_Clause + (With_Clause : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Next_Clause : Project_Node_Id) return Project_Node_Id + is + New_With_Clause : constant Project_Node_Id := + Default_Project_Node (In_Tree, N_With_Clause); + begin + Set_Name_Of (New_With_Clause, In_Tree, + Name_Of (With_Clause, In_Tree)); + Set_Path_Name_Of (New_With_Clause, In_Tree, + Path_Name_Of (With_Clause, In_Tree)); + Set_Project_Node_Of (New_With_Clause, In_Tree, + Project_Node_Of (With_Clause, In_Tree)); + Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause); + + return New_With_Clause; + end Copy_With_Clause; + -------------------------------------- -- Create_Virtual_Extending_Project -- -------------------------------------- procedure Create_Virtual_Extending_Project - (For_Project : Project_Node_Id; - Main_Project : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + Extension_Withs : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) is Virtual_Name : constant String := @@ -323,7 +359,8 @@ package body Prj.Part is Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); - -- With clause + -- Add a WITH clause to the main project to import the newly created + -- virtual extending project. Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); @@ -332,6 +369,21 @@ package body Prj.Part is (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); + -- Copy with clauses for projects imported by the extending-all project + + declare + Org_With_Clause : Project_Node_Id := Extension_Withs; + New_With_Clause : Project_Node_Id := Empty_Node; + begin + while Present (Org_With_Clause) loop + New_With_Clause := + Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause); + + Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree); + end loop; + Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause); + end; + -- Virtual project node Set_Location_Of @@ -371,6 +423,14 @@ package body Prj.Part is -- Look_For_Virtual_Projects_For -- ----------------------------------- + Extension_Withs : Project_Node_Id; + -- Head of the current EXTENDS ALL imports list. When creating virtual + -- projects for an EXTENDS ALL, we import in each virtual project all + -- of the projects that appear in WITH clauses of the extending projects. + -- This ensures that virtual projects share a consistent environment (in + -- particular if a project imported by one of the extending projects + -- replaces some runtime units). + procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; @@ -388,9 +448,13 @@ package body Prj.Part is Extended : Project_Node_Id := Empty_Node; -- Node for the eventual project extended by Proj + Extends_All : Boolean := False; + -- Set True if Proj is an EXTENDS ALL project + + Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs; + begin - -- Nothing to do if Proj is not defined or if it has already been - -- processed. + -- Nothing to do if Proj is undefined or has already been processed if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again @@ -401,13 +465,14 @@ package body Prj.Part is if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); + Extends_All := Is_Extending_All (Proj, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. if Potentially_Virtual and then No (Extended) then - Virtual_Hash.Set (Proj, Proj); + Virtual_Hash.Set (Proj, Extension_Withs); end if; -- Now check the projects it imports @@ -422,6 +487,14 @@ package body Prj.Part is (Imported, In_Tree, Potentially_Virtual => True); end if; + if Extends_All then + -- This is an EXTENDS ALL project: prepend each of its WITH + -- clauses to the currently active list of extension deps. + + Extension_Withs := + Copy_With_Clause (With_Clause, In_Tree, Extension_Withs); + end if; + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; @@ -431,6 +504,8 @@ package body Prj.Part is Look_For_Virtual_Projects_For (Extended, In_Tree, Potentially_Virtual => False); + + Extension_Withs := Saved_Extension_Withs; end if; end Look_For_Virtual_Projects_For; @@ -550,6 +625,7 @@ package body Prj.Part is Declaration : constant Project_Node_Id := Project_Declaration_Of (Project, In_Tree); begin + Extension_Withs := First_With_Clause_Of (Project, In_Tree); Look_For_Virtual_Projects_For (Extended_Project_Of (Declaration, In_Tree), In_Tree, Potentially_Virtual => False); @@ -595,11 +671,14 @@ package body Prj.Part is -- Now create all the virtual extending projects declare - Proj : Project_Node_Id := Virtual_Hash.Get_First; + Proj : Project_Node_Id := Empty_Node; + Withs : Project_Node_Id; begin - while Present (Proj) loop - Create_Virtual_Extending_Project (Proj, Project, In_Tree); - Proj := Virtual_Hash.Get_Next; + Virtual_Hash.Get_First (Proj, Withs); + while Withs /= Project_Node_High_Bound loop + Create_Virtual_Extending_Project + (Proj, Project, Withs, In_Tree); + Virtual_Hash.Get_Next (Proj, Withs); end loop; end; end if; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 2bab2b93049..7b247937639 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -926,6 +926,21 @@ CND(VEOL2, "Alternative EOL") #endif /* HAVE_TERMIOS */ +/* + + ----------------------------- + -- Pseudo terminal library -- + ----------------------------- + +*/ + +#if defined (__FreeBSD__) || defined (linux) +# define PTY_Library "-lutil" +#else +# define PTY_Library "" +#endif +CST(PTY_Library, "for g-exptty") + /** ** Sockets constants **/ diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index cae17c1e549..1c5dcc1a024 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -44,6 +44,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Primitives.Interrupt_Operations; @@ -60,6 +61,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index dc9f9a88fae..8893c010571 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -45,6 +45,7 @@ with Interfaces.C; with System.Task_Info; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.IO; @@ -56,6 +57,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 401438111cf..667603b73b7 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -50,6 +50,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -61,6 +62,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index ef0e391d3b4..92088e10cb4 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -43,6 +43,7 @@ with Interfaces.C; with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -58,6 +59,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index e4ef46699f2..cb534adf5b6 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -43,6 +43,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -54,6 +55,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 3c3e22b5604..eec3a9da10d 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -46,6 +46,7 @@ with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; with System.Float_Control; +with System.OS_Constants; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization @@ -58,6 +59,7 @@ with System.VxWorks.Ext; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 66b0b5dffee..12fbd71386e 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -34,14 +34,12 @@ with System.Parameters; with System.Tasking; -with System.OS_Constants; with System.OS_Interface; package System.Task_Primitives.Operations is pragma Preelaborate; package ST renames System.Tasking; - package OSC renames System.OS_Constants; package OSI renames System.OS_Interface; procedure Initialize (Environment_Task : ST.Task_Id); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 16bfbeb539a..5cc06e7d899 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11799,6 +11799,11 @@ package body Sem_Ch3 is -- needed, since checks may cause duplication of the expressions -- which must not be reevaluated. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Low_Bound (R)); Force_Evaluation (High_Bound (R)); @@ -18339,6 +18344,11 @@ package body Sem_Ch3 is -- if needed, before applying checks, since checks may cause -- duplication of the expression without forcing evaluation. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Lo); Force_Evaluation (Hi); @@ -18449,6 +18459,11 @@ package body Sem_Ch3 is -- Case of other than an explicit N_Range node + -- The forced evaluation removes side effects from expressions, which + -- should occur also in Alfa mode. Otherwise, we end up with unexpected + -- insertions of actions at places where this is not supposed to occur, + -- e.g. on default parameters of a call. + elsif Expander_Active then Get_Index_Bounds (R, Lo, Hi); Force_Evaluation (Lo); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 0e6c5cf98bd..073bc2b840a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -75,6 +75,14 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + procedure Pre_Analyze_Range (R_Copy : Node_Id); + -- Determine expected type of range or domain of iteration of Ada 2012 + -- loop by analyzing separate copy. Do the analysis and resolution of the + -- copy of the bound(s) with expansion disabled, to prevent the generation + -- of finalization actions. This prevents memory leaks when the bounds + -- contain calls to functions returning controlled arrays or when the + -- domain of iteration is a container. + ------------------------ -- Analyze_Assignment -- ------------------------ @@ -1618,90 +1626,6 @@ package body Sem_Ch5 is -- calls that use the secondary stack, returning True if any such call -- is found, and False otherwise. - procedure Pre_Analyze_Range (R_Copy : Node_Id); - -- Determine expected type of range or domain of iteration of Ada 2012 - -- loop by analyzing separate copy. Do the analysis and resolution of - -- the copy of the bound(s) with expansion disabled, to prevent the - -- generation of finalization actions. This prevents memory leaks when - -- the bounds contain calls to functions returning controlled arrays or - -- when the domain of iteration is a container. - - ----------------------- - -- Pre_Analyze_Range -- - ----------------------- - - procedure Pre_Analyze_Range (R_Copy : Node_Id) is - Save_Analysis : Boolean; - begin - Save_Analysis := Full_Analysis; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - Analyze (R_Copy); - - if Nkind (R_Copy) in N_Subexpr - and then Is_Overloaded (R_Copy) - then - - -- Apply preference rules for range of predefined integer types, - -- or diagnose true ambiguity. - - declare - I : Interp_Index; - It : Interp; - Found : Entity_Id := Empty; - - begin - Get_First_Interp (R_Copy, I, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then - if No (Found) then - Found := It.Typ; - else - if Scope (Found) = Standard_Standard then - null; - - elsif Scope (It.Typ) = Standard_Standard then - Found := It.Typ; - - else - -- Both of them are user-defined - - Error_Msg_N - ("ambiguous bounds in range of iteration", - R_Copy); - Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\\} ", R_Copy, Found); - Error_Msg_NE ("\\} ", R_Copy, It.Typ); - exit; - end if; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - if Is_Entity_Name (R_Copy) - and then Is_Type (Entity (R_Copy)) - then - - -- Subtype mark in iteration scheme - - null; - - elsif Nkind (R_Copy) in N_Subexpr then - - -- Expression in range, or Ada 2012 iterator - - Resolve (R_Copy); - end if; - - Expander_Mode_Restore; - Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; - -------------------- -- Process_Bounds -- -------------------- @@ -1855,7 +1779,7 @@ package body Sem_Ch5 is if New_Lo_Bound /= Lo and then Is_Static_Expression (New_Lo_Bound) then - Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); + Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); end if; if New_Hi_Bound /= Hi @@ -2034,7 +1958,7 @@ package body Sem_Ch5 is begin if Present (H) and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) + Enclosing_Dynamic_Scope (Id) and then Ekind (H) = E_Variable and then Is_Discrete_Type (Etype (H)) then @@ -2059,7 +1983,7 @@ package body Sem_Ch5 is then Process_Bounds (DS); - -- expander not active or else range of iteration is a subtype + -- Expander not active or else range of iteration is a subtype -- indication, an entity, or a function call that yields an -- aggregate or a container. @@ -2513,12 +2437,95 @@ package body Sem_Ch5 is ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is - Loop_Statement : constant Node_Id := N; - Id : constant Node_Id := Identifier (Loop_Statement); - Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + function Is_Container_Iterator (Iter : Node_Id) return Boolean; + -- Given a loop iteration scheme, determine whether it is an Ada 2012 + -- container iteration. + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean; + -- Determine whether node N is the sole statement of a block + + --------------------------- + -- Is_Container_Iterator -- + --------------------------- + + function Is_Container_Iterator (Iter : Node_Id) return Boolean is + begin + -- Infinite loop + + if No (Iter) then + return False; + + -- While loop + + elsif Present (Condition (Iter)) then + return False; + + -- for Def_Id in [reverse] Name loop + -- for Def_Id [: Subtype_Indication] of [reverse] Name loop + + elsif Present (Iterator_Specification (Iter)) then + declare + Nam : constant Node_Id := Name (Iterator_Specification (Iter)); + Nam_Copy : Node_Id; + + begin + Nam_Copy := New_Copy_Tree (Nam); + Set_Parent (Nam_Copy, Parent (Nam)); + Pre_Analyze_Range (Nam_Copy); + + -- The only two options here are iteration over a container or + -- an array. + + return not Is_Array_Type (Etype (Nam_Copy)); + end; + + -- for Def_Id in [reverse] Discrete_Subtype_Definition loop + + else + declare + LP : constant Node_Id := Loop_Parameter_Specification (Iter); + DS : constant Node_Id := Discrete_Subtype_Definition (LP); + DS_Copy : Node_Id; + + begin + DS_Copy := New_Copy_Tree (DS); + Set_Parent (DS_Copy, Parent (DS)); + Pre_Analyze_Range (DS_Copy); + + -- Check for a call to Iterate () + + return + Nkind (DS_Copy) = N_Function_Call + and then Needs_Finalization (Etype (DS_Copy)); + end; + end if; + end Is_Container_Iterator; + + ------------------------- + -- Is_Wrapped_In_Block -- + ------------------------- + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean is + HSS : constant Node_Id := Parent (N); + + begin + return + Nkind (HSS) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (HSS)) = N_Block_Statement + and then First (Statements (HSS)) = N + and then No (Next (First (Statements (HSS)))); + end Is_Wrapped_In_Block; + + -- Local declarations + + Id : constant Node_Id := Identifier (N); + Iter : constant Node_Id := Iteration_Scheme (N); + Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + -- Start of processing for Analyze_Loop_Statement + begin if Present (Id) then @@ -2534,15 +2541,13 @@ package body Sem_Ch5 is if No (Ent) then if Total_Errors_Detected /= 0 then - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); else raise Program_Error; end if; else - Generate_Reference (Ent, Loop_Statement, ' '); + Generate_Reference (Ent, N, ' '); Generate_Definition (Ent); -- If we found a label, mark its type. If not, ignore it, since it @@ -2555,7 +2560,7 @@ package body Sem_Ch5 is Set_Ekind (Ent, E_Loop); if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then - Set_Label_Construct (Parent (Ent), Loop_Statement); + Set_Label_Construct (Parent (Ent), N); end if; end if; end if; @@ -2563,11 +2568,28 @@ package body Sem_Ch5 is -- Case of no identifier present else - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Loop_Statement); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, N); + end if; + + -- Iteration over a container in Ada 2012 involves the creation of a + -- controlled iterator object. Wrap the loop in a block to ensure the + -- timely finalization of the iterator and release of container locks. + + if Ada_Version >= Ada_2012 + and then Is_Container_Iterator (Iter) + and then not Is_Wrapped_In_Block (N) + then + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (N))))); + + Analyze (N); + return; end if; -- Kill current values on entry to loop, since statements in the body of @@ -2610,7 +2632,7 @@ package body Sem_Ch5 is end; end if; - Analyze_Statements (Statements (Loop_Statement)); + Analyze_Statements (Statements (N)); end if; -- Finish up processing for the loop. We kill all current values, since @@ -2619,7 +2641,7 @@ package body Sem_Ch5 is -- know will execute at least once, but it's not worth the trouble and -- the front end is not in the business of flow tracing. - Process_End_Label (Loop_Statement, 'e', Ent); + Process_End_Label (N, 'e', Ent); End_Scope; Kill_Current_Values; @@ -2871,4 +2893,76 @@ package body Sem_Ch5 is end if; end Check_Unreachable_Code; + ----------------------- + -- Pre_Analyze_Range -- + ----------------------- + + procedure Pre_Analyze_Range (R_Copy : Node_Id) is + Save_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Nkind (R_Copy) in N_Subexpr + and then Is_Overloaded (R_Copy) + then + -- Apply preference rules for range of predefined integer types, or + -- diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + -- Subtype mark in iteration scheme + + if Is_Entity_Name (R_Copy) + and then Is_Type (Entity (R_Copy)) + then + null; + + -- Expression in range, or Ada 2012 iterator + + elsif Nkind (R_Copy) in N_Subexpr then + Resolve (R_Copy); + end if; + + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + end Pre_Analyze_Range; + end Sem_Ch5; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 17f802fc14e..98913dbccce 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -52,6 +52,7 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; @@ -2848,6 +2849,13 @@ package body Sem_Ch8 is ("?redundant renaming, entity is directly visible", Name (N)); end if; + -- Implementation-defined aspect specifications can appear in a renaming + -- declaration, but not language-defined ones. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, New_S); + end if; + Ada_Version := Save_AV; Ada_Version_Explicit := Save_AV_Exp; end Analyze_Subprogram_Renaming; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 057f0b767be..16b8087ad66 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -911,6 +911,9 @@ package body Sem_Ch9 is -- Note: originally this check was not performed here, but in that -- case the check happens deep in the expander, and the message is -- posted at the wrong location, and omitted in -gnatc mode. + -- If the type of the entry index is a generic formal, no check + -- is possible. In an instance, the check is not static and a run- + -- time exception will be raised if the bounds are unreasonable. declare PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); @@ -921,12 +924,19 @@ package body Sem_Ch9 is UBR : Node_Id; begin - if Nkind (D_Sdef) = N_Range then + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + then + goto Skip_LB; + + elsif Nkind (D_Sdef) = N_Range then LBR := Low_Bound (D_Sdef); + elsif Is_Entity_Name (D_Sdef) and then Is_Type (Entity (D_Sdef)) then LBR := Type_Low_Bound (Entity (D_Sdef)); + else goto Skip_LB; end if; @@ -939,12 +949,19 @@ package body Sem_Ch9 is end if; <<Skip_LB>> - if Nkind (D_Sdef) = N_Range then + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + then + goto Skip_UB; + + elsif Nkind (D_Sdef) = N_Range then UBR := High_Bound (D_Sdef); + elsif Is_Entity_Name (D_Sdef) and then Is_Type (Entity (D_Sdef)) then UBR := Type_High_Bound (Entity (D_Sdef)); + else goto Skip_UB; end if; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 5aecd239c4b..9fc3d97d2e2 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -6377,6 +6377,30 @@ package VMS_Data is -- of the directory specified in the project file. If the subdirectory -- does not exist, it is created automatically. + S_Pretty_Types : aliased constant S := "/TYPE_CASING=" & + "AS_DECLARED " & + "-ntD " & + "LOWER_CASE " & + "-ntL " & + "UPPER_CASE " & + "-ntU " & + "MIXED_CASE " & + "-ntM"; + -- /TYPE_CASING=name-option + -- + -- Specify the casing of type and subtype. If not specified, the + -- casing of these names is defined by the NAME_CASING option. + -- 'name-option' may be one of: + -- + -- AS_DECLARED Name casing for defining occurrences are + -- as they appear in the source file. + -- + -- LOWER_CASE Namess are in lower case. + -- + -- UPPER_CASE Namess are in upper case. + -- + -- MIXED_CASE Namess are in mixed case. + S_Pretty_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) @@ -6440,6 +6464,7 @@ package VMS_Data is S_Pretty_Stnm_On_Nw_Line 'Access, S_Pretty_Specific 'Access, S_Pretty_Standard 'Access, + S_Pretty_Types 'Access, S_Pretty_Verbose 'Access, S_Pretty_Warnings 'Access); |