git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2012-02-17  Yannick Moy  <moy@adacore.com>

	* gnat_rm.texi: Minor shuffling.

2012-02-17  Ed Schonberg  <schonberg@adacore.com>

	* aspects.adb: Expression functions can carry pre/postconditions.
	* par-ch6.adb (P_Subprogram): look for optional pre/postconditions
	in an expression function.
	* sem_prag (Check_Precondition_Postcondition): legal on expression
	functions.

2012-02-17  Vincent Pucci  <pucci@adacore.com>

	* a-cdlili.adb, a-cidlli.adb, a-cihama.adb, a-cimutr.adb,
	* a-ciorma.adb, a-cohama.adb, a-coinve.adb, a-comutr.adb,
	* a-convec.adb, a-coorma.adb (Adjust): New routine.
	(Constant_Reference): Increment Busy and Lock counters.
	(Reference): Increase Busy and Lock counters.
	(Finalize): New routine.
	* a-cihase.adb, a-ciorse.adb, a-cohase.adb, a-coorse.adb:
	(Adjust): New routine.	(Constant_Reference): Increment Busy
	and Lock counters.
	(Finalize): New routine.
	* a-cdlili.ads, a-cidlli.ads, a-cihama.ads, a-cihase.ads,
	* a-cimutr.ads, a-ciorma.ads, a-ciorse.ads, a-cohama.ads,
	* a-cohase.ads, a-coinve.ads, a-comutr.ads, a-convec.ads,
	* a-coorma.ads, a-coorse: Controlled component added to the
	reference types.

2012-02-17  Robert Dewar  <dewar@adacore.com>

	* restrict.adb (Check_Restriction): Add special handling for
	No_Obsolescent_Features.

2012-02-17  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Find_Finalize_Address): When dealing with an
	internally built full view for a type with unknown discriminants,
	use the original record type.

From-SVN: r184341
This commit is contained in:
Arnaud Charlet 2012-02-17 15:15:46 +01:00
parent 51f894e62c
commit 794b9b7240
35 changed files with 1350 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
2012-02-17 Yannick Moy <moy@adacore.com>
* gnat_rm.texi: Minor shuffling.
2012-02-17 Ed Schonberg <schonberg@adacore.com>
* aspects.adb: Expression functions can carry pre/postconditions.
* par-ch6.adb (P_Subprogram): look for optional pre/postconditions
in an expression function.
* sem_prag (Check_Precondition_Postcondition): legal on expression
functions.
2012-02-17 Vincent Pucci <pucci@adacore.com>
* a-cdlili.adb, a-cidlli.adb, a-cihama.adb, a-cimutr.adb,
* a-ciorma.adb, a-cohama.adb, a-coinve.adb, a-comutr.adb,
* a-convec.adb, a-coorma.adb (Adjust): New routine.
(Constant_Reference): Increment Busy and Lock counters.
(Reference): Increase Busy and Lock counters.
(Finalize): New routine.
* a-cihase.adb, a-ciorse.adb, a-cohase.adb, a-coorse.adb:
(Adjust): New routine. (Constant_Reference): Increment Busy
and Lock counters.
(Finalize): New routine.
* a-cdlili.ads, a-cidlli.ads, a-cihama.ads, a-cihase.ads,
* a-cimutr.ads, a-ciorma.ads, a-ciorse.ads, a-cohama.ads,
* a-cohase.ads, a-coinve.ads, a-comutr.ads, a-convec.ads,
* a-coorma.ads, a-coorse: Controlled component added to the
reference types.
2012-02-17 Robert Dewar <dewar@adacore.com>
* restrict.adb (Check_Restriction): Add special handling for
No_Obsolescent_Features.
2012-02-17 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (Find_Finalize_Address): When dealing with an
internally built full view for a type with unknown discriminants,
use the original record type.
2012-02-17 Robert Dewar <dewar@adacore.com> 2012-02-17 Robert Dewar <dewar@adacore.com>
* sem_dim.adb: Minor reformatting. * sem_dim.adb: Minor reformatting.

59
gcc/ada/a-cdlili.adb
View File

@ -142,6 +142,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
end loop; end loop;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : List renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Append -- -- Append --
------------ ------------
@ -244,7 +258,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
return (Element => Position.Node.Element'Access); declare
C : List renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -442,6 +469,22 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : List renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1336,7 +1379,19 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Vet (Position), "bad cursor in function Reference"); pragma Assert (Vet (Position), "bad cursor in function Reference");
return (Element => Position.Node.Element'Access); declare
C : List renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
--------------------- ---------------------

23
gcc/ada/a-cdlili.ads
View File

@ -104,10 +104,12 @@ package Ada.Containers.Doubly_Linked_Lists is
function Constant_Reference function Constant_Reference
(Container : aliased List; (Container : aliased List;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out List; (Container : aliased in out List;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out List; Source : List); procedure Assign (Target : in out List; Source : List);
@ -305,8 +307,22 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
Container : List_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -321,7 +337,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

58
gcc/ada/a-cidlli.adb
View File

@ -166,6 +166,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end loop; end loop;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : List renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Append -- -- Append --
------------ ------------
@ -271,7 +285,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
return (Element => Position.Node.Element.all'Access); declare
C : List renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -479,6 +505,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : List renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1372,7 +1414,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Vet (Position), "bad cursor in function Reference"); pragma Assert (Vet (Position), "bad cursor in function Reference");
return (Element => Position.Node.Element.all'Access); declare
C : List renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
--------------------- ---------------------

23
gcc/ada/a-cidlli.ads
View File

@ -103,10 +103,12 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Constant_Reference function Constant_Reference
(Container : aliased List; (Container : aliased List;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out List; (Container : aliased in out List;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out List; Source : List); procedure Assign (Target : in out List; Source : List);
@ -299,8 +301,22 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
Container : List_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -315,7 +331,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

97
gcc/ada/a-cihama.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -136,6 +136,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
M : Map renames Control.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -217,7 +232,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Vet (Position), (Vet (Position),
"Position cursor in Constant_Reference is bad"); "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -235,7 +264,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Program_Error with "key has no element"; raise Program_Error with "key has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
M : Map renames Container'Unrestricted_Access.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -484,6 +527,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
M : Map renames Control.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1028,7 +1088,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Vet (Position), (Vet (Position),
"Position cursor in function Reference is bad"); "Position cursor in function Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -1046,7 +1119,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Program_Error with "key has no element"; raise Program_Error with "key has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
M : Map renames Container'Unrestricted_Access.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
------------- -------------

25
gcc/ada/a-cihama.ads
View File

@ -147,18 +147,22 @@ package Ada.Containers.Indefinite_Hashed_Maps is
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type; Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Key : Key_Type) return Reference_Type; Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map); procedure Assign (Target : in out Map; Source : Map);
@ -363,8 +367,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Map_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -379,7 +397,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

62
gcc/ada/a-cihase.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -165,6 +165,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -228,7 +242,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
return (Element => Position.Node.Element.all'Access); declare
HT : Hash_Table_Type renames Position.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -610,6 +637,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1926,7 +1969,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------

17
gcc/ada/a-cihase.ads
View File

@ -152,6 +152,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Constant_Reference function Constant_Reference
(Container : aliased Set; (Container : aliased Set;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set); procedure Assign (Target : in out Set; Source : Set);
@ -507,8 +508,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Set_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

61
gcc/ada/a-cimutr.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -204,6 +204,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Container.Count := Source_Count; Container.Count := Source_Count;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------------- -------------------
-- Ancestor_Find -- -- Ancestor_Find --
------------------- -------------------
@ -472,7 +486,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
-- pragma Assert (Vet (Position), -- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad"); -- "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
C : Tree renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -985,6 +1012,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
B := B - 1; B := B - 1;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -2041,7 +2084,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
-- pragma Assert (Vet (Position), -- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad"); -- "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
C : Tree renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
-------------------- --------------------

25
gcc/ada/a-cimutr.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
@ -112,10 +112,12 @@ package Ada.Containers.Indefinite_Multiway_Trees is
function Constant_Reference function Constant_Reference
(Container : aliased Tree; (Container : aliased Tree;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Tree; (Container : aliased in out Tree;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Tree; Source : Tree); procedure Assign (Target : in out Tree; Source : Tree);
@ -378,8 +380,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Tree_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -394,7 +410,10 @@ private
for Constant_Reference_Type'Write use Write; for Constant_Reference_Type'Write use Write;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

91
gcc/ada/a-ciorma.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -291,6 +291,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
Adjust (Container.Tree); Adjust (Container.Tree);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
T : Tree_Type renames Control.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -379,7 +393,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node), pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor in Constant_Reference is bad"); "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -397,7 +424,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -586,6 +626,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
T : Tree_Type renames Control.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1360,7 +1416,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node), pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor in function Reference is bad"); "Position cursor in function Reference is bad");
return (Element => Position.Node.Element.all'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -1378,7 +1446,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
------------- -------------

25
gcc/ada/a-ciorma.ads
View File

@ -109,18 +109,22 @@ package Ada.Containers.Indefinite_Ordered_Maps is
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type; Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Key : Key_Type) return Reference_Type; Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map); procedure Assign (Target : in out Map; Source : Map);
@ -292,8 +296,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Map_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -308,7 +326,10 @@ private
for Constant_Reference_Type'Write use Write; for Constant_Reference_Type'Write use Write;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

62
gcc/ada/a-ciorse.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -325,6 +325,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Adjust (Container.Tree); Adjust (Container.Tree);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
Tree : Tree_Type renames Control.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -398,7 +412,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Vet (Container.Tree, Position.Node), (Vet (Container.Tree, Position.Node),
"bad cursor in Constant_Reference"); "bad cursor in Constant_Reference");
return (Element => Position.Node.Element.all'Access); declare
Tree : Tree_Type renames Position.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -617,6 +644,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
Tree : Tree_Type renames Control.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -782,7 +825,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
raise Program_Error with "Node has no element"; raise Program_Error with "Node has no element";
end if; end if;
return (Element => Node.Element.all'Access); declare
Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------

17
gcc/ada/a-ciorse.ads
View File

@ -99,6 +99,7 @@ package Ada.Containers.Indefinite_Ordered_Sets is
function Constant_Reference function Constant_Reference
(Container : aliased Set; (Container : aliased Set;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set); procedure Assign (Target : in out Set; Source : Set);
@ -376,8 +377,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Set_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

90
gcc/ada/a-cohama.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -135,6 +135,20 @@ package body Ada.Containers.Hashed_Maps is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -211,7 +225,19 @@ package body Ada.Containers.Hashed_Maps is
(Vet (Position), (Vet (Position),
"Position cursor in Constant_Reference is bad"); "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -225,7 +251,20 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error with "key not in map"; raise Constraint_Error with "key not in map";
end if; end if;
return (Element => Node.Element'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -439,6 +478,22 @@ package body Ada.Containers.Hashed_Maps is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -920,7 +975,19 @@ package body Ada.Containers.Hashed_Maps is
(Vet (Position), (Vet (Position),
"Position cursor in function Reference is bad"); "Position cursor in function Reference is bad");
return (Element => Position.Node.Element'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -934,7 +1001,20 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error with "key not in map"; raise Constraint_Error with "key not in map";
end if; end if;
return (Element => Node.Element'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
--------------- ---------------

25
gcc/ada/a-cohama.ads
View File

@ -148,18 +148,22 @@ package Ada.Containers.Hashed_Maps is
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type; Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Key : Key_Type) return Reference_Type; Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map); procedure Assign (Target : in out Map; Source : Map);
@ -369,8 +373,22 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
Container : Map_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -385,7 +403,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

62
gcc/ada/a-cohase.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -161,6 +161,20 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -218,7 +232,20 @@ package body Ada.Containers.Hashed_Sets is
pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
return (Element => Position.Node.Element'Access); declare
HT : Hash_Table_Type renames Position.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -548,6 +575,22 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Finalize (Container.HT); HT_Ops.Finalize (Container.HT);
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
HT : Hash_Table_Type renames Control.Container.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1746,7 +1789,20 @@ package body Ada.Containers.Hashed_Sets is
raise Constraint_Error with "Key not in set"; raise Constraint_Error with "Key not in set";
end if; end if;
return (Element => Node.Element'Access); declare
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------

17
gcc/ada/a-cohase.ads
View File

@ -153,6 +153,7 @@ package Ada.Containers.Hashed_Sets is
function Constant_Reference function Constant_Reference
(Container : aliased Set; (Container : aliased Set;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set); procedure Assign (Target : in out Set; Source : Set);
@ -509,8 +510,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Set_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

97
gcc/ada/a-coinve.adb
View File

@ -578,6 +578,20 @@ package body Ada.Containers.Indefinite_Vectors is
end; end;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Append -- -- Append --
------------ ------------
@ -697,7 +711,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Position is empty"; raise Constraint_Error with "element at Position is empty";
end if; end if;
return (Element => E.all'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => E.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -717,7 +744,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Index is empty"; raise Constraint_Error with "element at Index is empty";
end if; end if;
return (Element => E.all'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => E.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -1131,6 +1171,22 @@ package body Ada.Containers.Indefinite_Vectors is
B := B - 1; B := B - 1;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1402,6 +1458,8 @@ package body Ada.Containers.Indefinite_Vectors is
Array_Type => Elements_Array, Array_Type => Elements_Array,
"<" => Is_Less); "<" => Is_Less);
-- Start of processing for Sort
begin begin
if Container.Last <= Index_Type'First then if Container.Last <= Index_Type'First then
return; return;
@ -3047,7 +3105,19 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Position is empty"; raise Constraint_Error with "element at Position is empty";
end if; end if;
return (Element => E.all'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => E.all'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -3067,7 +3137,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Index is empty"; raise Constraint_Error with "element at Index is empty";
end if; end if;
return (Element => E.all'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => E.all'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
--------------------- ---------------------
@ -3430,9 +3513,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- catch more things) instead of for element tampering (which will catch -- catch more things) instead of for element tampering (which will catch
-- fewer things). It's true that the elements of this vector container -- fewer things). It's true that the elements of this vector container
-- could be safely moved around while (say) an iteration is taking place -- could be safely moved around while (say) an iteration is taking place
-- (iteration only increments the busy counter), and so technically -- (iteration only increments the busy counter), and so technically all
-- all we would need here is a test for element tampering (indicated -- we would need here is a test for element tampering (indicated by the
-- by the lock counter), that's simply an artifact of our array-based -- lock counter), that's simply an artifact of our array-based
-- implementation. Logically Reverse_Elements requires a check for -- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering. -- cursor tampering.

25
gcc/ada/a-coinve.ads
View File

@ -117,18 +117,22 @@ package Ada.Containers.Indefinite_Vectors is
function Constant_Reference function Constant_Reference
(Container : aliased Vector; (Container : aliased Vector;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Vector; (Container : aliased in out Vector;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Vector; (Container : aliased Vector;
Index : Index_Type) return Constant_Reference_Type; Index : Index_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Vector; (Container : aliased in out Vector;
Index : Index_Type) return Reference_Type; Index : Index_Type) return Reference_Type;
pragma Inline (Reference);
function To_Cursor function To_Cursor
(Container : Vector; (Container : Vector;
@ -408,8 +412,22 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
Container : Vector_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -424,7 +442,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

61
gcc/ada/a-comutr.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -206,6 +206,20 @@ package body Ada.Containers.Multiway_Trees is
Container.Count := Source_Count; Container.Count := Source_Count;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------------- -------------------
-- Ancestor_Find -- -- Ancestor_Find --
------------------- -------------------
@ -464,7 +478,20 @@ package body Ada.Containers.Multiway_Trees is
-- pragma Assert (Vet (Position), -- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad"); -- "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element'Access); declare
C : Tree renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -957,6 +984,22 @@ package body Ada.Containers.Multiway_Trees is
B := B - 1; B := B - 1;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -2053,7 +2096,19 @@ package body Ada.Containers.Multiway_Trees is
-- pragma Assert (Vet (Position), -- pragma Assert (Vet (Position),
-- "Position cursor in Constant_Reference is bad"); -- "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element'Access); declare
C : Tree renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
-------------------- --------------------

25
gcc/ada/a-comutr.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
@ -111,10 +111,12 @@ package Ada.Containers.Multiway_Trees is
function Constant_Reference function Constant_Reference
(Container : aliased Tree; (Container : aliased Tree;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Tree; (Container : aliased in out Tree;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Tree; Source : Tree); procedure Assign (Target : in out Tree; Source : Tree);
@ -423,8 +425,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Tree_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -439,7 +455,10 @@ private
for Constant_Reference_Type'Write use Write; for Constant_Reference_Type'Write use Write;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

91
gcc/ada/a-convec.adb
View File

@ -396,6 +396,20 @@ package body Ada.Containers.Vectors is
end; end;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Append -- -- Append --
------------ ------------
@ -499,7 +513,21 @@ package body Ada.Containers.Vectors is
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if; end if;
return (Element => Container.Elements.EA (Position.Index)'Access); declare
C : Vector renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element =>
Container.Elements.EA (Position.Index)'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -510,7 +538,20 @@ package body Ada.Containers.Vectors is
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else else
return (Element => Container.Elements.EA (Index)'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end if; end if;
end Constant_Reference; end Constant_Reference;
@ -825,6 +866,22 @@ package body Ada.Containers.Vectors is
B := B - 1; B := B - 1;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -2601,7 +2658,20 @@ package body Ada.Containers.Vectors is
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if; end if;
return (Element => Container.Elements.EA (Position.Index)'Access); declare
C : Vector renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element =>
Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -2612,7 +2682,20 @@ package body Ada.Containers.Vectors is
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else else
return (Element => Container.Elements.EA (Index)'Access); declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end if; end if;
end Reference; end Reference;

25
gcc/ada/a-convec.ads
View File

@ -158,18 +158,22 @@ package Ada.Containers.Vectors is
function Constant_Reference function Constant_Reference
(Container : aliased Vector; (Container : aliased Vector;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Vector; (Container : aliased in out Vector;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Vector; (Container : aliased Vector;
Index : Index_Type) return Constant_Reference_Type; Index : Index_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Vector; (Container : aliased in out Vector;
Index : Index_Type) return Reference_Type; Index : Index_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Vector; Source : Vector); procedure Assign (Target : in out Vector; Source : Vector);
@ -416,8 +420,22 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
Container : Vector_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -432,7 +450,10 @@ private
for Constant_Reference_Type'Read use Read; for Constant_Reference_Type'Read use Read;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

90
gcc/ada/a-coorma.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -252,6 +252,20 @@ package body Ada.Containers.Ordered_Maps is
Adjust (Container.Tree); Adjust (Container.Tree);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
T : Tree_Type renames Control.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -340,7 +354,19 @@ package body Ada.Containers.Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node), pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor in Constant_Reference is bad"); "Position cursor in Constant_Reference is bad");
return (Element => Position.Node.Element'Access); declare
T : Tree_Type renames Position.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
@ -354,7 +380,20 @@ package body Ada.Containers.Ordered_Maps is
raise Constraint_Error with "key not in map"; raise Constraint_Error with "key not in map";
end if; end if;
return (Element => Node.Element'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -532,6 +571,22 @@ package body Ada.Containers.Ordered_Maps is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
T : Tree_Type renames Control.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -1294,7 +1349,19 @@ package body Ada.Containers.Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node), pragma Assert (Vet (Container.Tree, Position.Node),
"Position cursor in function Reference is bad"); "Position cursor in function Reference is bad");
return (Element => Position.Node.Element'Access); declare
T : Tree_Type renames Position.Container.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Reference_Type :=
(Element => Position.Node.Element'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
@ -1308,7 +1375,20 @@ package body Ada.Containers.Ordered_Maps is
raise Constraint_Error with "key not in map"; raise Constraint_Error with "key not in map";
end if; end if;
return (Element => Node.Element'Access); declare
T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
L : Natural renames T.Lock;
begin
return R : constant Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
------------- -------------

25
gcc/ada/a-coorma.ads
View File

@ -108,18 +108,22 @@ package Ada.Containers.Ordered_Maps is
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Position : Cursor) return Reference_Type; Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference function Constant_Reference
(Container : aliased Map; (Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type; Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference function Reference
(Container : aliased in out Map; (Container : aliased in out Map;
Key : Key_Type) return Reference_Type; Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map); procedure Assign (Target : in out Map; Source : Map);
@ -293,8 +297,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Map_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
@ -309,7 +327,10 @@ private
for Constant_Reference_Type'Write use Write; for Constant_Reference_Type'Write use Write;
type Reference_Type type Reference_Type
(Element : not null access Element_Type) is null record; (Element : not null access Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

62
gcc/ada/a-coorse.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -285,6 +285,20 @@ package body Ada.Containers.Ordered_Sets is
Adjust (Container.Tree); Adjust (Container.Tree);
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
Tree : Tree_Type renames Control.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Assign -- -- Assign --
------------ ------------
@ -353,7 +367,20 @@ package body Ada.Containers.Ordered_Sets is
(Vet (Container.Tree, Position.Node), (Vet (Container.Tree, Position.Node),
"bad cursor in Constant_Reference"); "bad cursor in Constant_Reference");
return (Element => Position.Node.Element'Access); declare
Tree : Tree_Type renames Position.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------
@ -554,6 +581,22 @@ package body Ada.Containers.Ordered_Sets is
end if; end if;
end Finalize; end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
Tree : Tree_Type renames Control.Container.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
---------- ----------
-- Find -- -- Find --
---------- ----------
@ -699,7 +742,20 @@ package body Ada.Containers.Ordered_Sets is
raise Constraint_Error with "key not in set"; raise Constraint_Error with "key not in set";
end if; end if;
return (Element => Node.Element'Access); declare
Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
begin
return R : constant Constant_Reference_Type :=
(Element => Node.Element'Access,
Control =>
(Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
-------------- --------------

17
gcc/ada/a-coorse.ads
View File

@ -100,6 +100,7 @@ package Ada.Containers.Ordered_Sets is
function Constant_Reference function Constant_Reference
(Container : aliased Set; (Container : aliased Set;
Position : Cursor) return Constant_Reference_Type; Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set); procedure Assign (Target : in out Set; Source : Set);
@ -359,8 +360,22 @@ private
for Cursor'Read use Read; for Cursor'Read use Read;
type Reference_Control_Type is
new Controlled with record
Container : Set_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record; (Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write procedure Write
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;

1
gcc/ada/aspects.adb
View File

@ -193,6 +193,7 @@ package body Aspects is
N_Entry_Declaration => True, N_Entry_Declaration => True,
N_Exception_Declaration => True, N_Exception_Declaration => True,
N_Exception_Renaming_Declaration => True, N_Exception_Renaming_Declaration => True,
N_Expression_Function => True,
N_Formal_Abstract_Subprogram_Declaration => True, N_Formal_Abstract_Subprogram_Declaration => True,
N_Formal_Concrete_Subprogram_Declaration => True, N_Formal_Concrete_Subprogram_Declaration => True,
N_Formal_Object_Declaration => True, N_Formal_Object_Declaration => True,

7
gcc/ada/exp_util.adb
View File

@ -483,6 +483,13 @@ package body Exp_Util is
Utyp := Base_Type (Utyp); Utyp := Base_Type (Utyp);
end if; end if;
-- When dealing with an internally built full view for a type with
-- unknown discriminants, use the original record type.
if Is_Underlying_Record_View (Utyp) then
Utyp := Etype (Utyp);
end if;
return TSS (Utyp, TSS_Finalize_Address); return TSS (Utyp, TSS_Finalize_Address);
end Find_Finalize_Address; end Find_Finalize_Address;

14
gcc/ada/gnat_rm.texi
View File

@ -355,6 +355,7 @@ Partition-Wide Restrictions
* No_Task_Allocators:: * No_Task_Allocators::
* No_Task_Attributes_Package:: * No_Task_Attributes_Package::
* No_Task_Hierarchy:: * No_Task_Hierarchy::
* No_Task_Termination::
* No_Tasking:: * No_Tasking::
* No_Terminate_Alternatives:: * No_Terminate_Alternatives::
* No_Unchecked_Access:: * No_Unchecked_Access::
@ -376,7 +377,6 @@ Program Unit Level Restrictions
* No_Obsolescent_Features:: * No_Obsolescent_Features::
* No_Wide_Characters:: * No_Wide_Characters::
* SPARK:: * SPARK::
* No_Task_Termination::
The Implementation of Standard I/O The Implementation of Standard I/O
@ -6993,6 +6993,7 @@ then all compilation units in the partition must obey the restriction).
* No_Task_Allocators:: * No_Task_Allocators::
* No_Task_Attributes_Package:: * No_Task_Attributes_Package::
* No_Task_Hierarchy:: * No_Task_Hierarchy::
* No_Task_Termination::
* No_Tasking:: * No_Tasking::
* No_Terminate_Alternatives:: * No_Terminate_Alternatives::
* No_Unchecked_Access:: * No_Unchecked_Access::
@ -7541,6 +7542,11 @@ explicit dependencies on the package @code{Ada.Task_Attributes}.
[RM D.7] All (non-environment) tasks depend [RM D.7] All (non-environment) tasks depend
directly on the environment task of the partition. directly on the environment task of the partition.
@node No_Task_Termination
@unnumberedsubsec No_Task_Termination
@findex No_Task_Termination
[RM D.7] Tasks which terminate are erroneous.
@node No_Tasking @node No_Tasking
@unnumberedsubsec No_Tasking @unnumberedsubsec No_Tasking
@findex No_Tasking @findex No_Tasking
@ -7605,7 +7611,6 @@ other compilation units in the partition.
* No_Obsolescent_Features:: * No_Obsolescent_Features::
* No_Wide_Characters:: * No_Wide_Characters::
* SPARK:: * SPARK::
* No_Task_Termination::
@end menu @end menu
@node No_Elaboration_Code @node No_Elaboration_Code
@ -7764,11 +7769,6 @@ This restriction can be useful in providing an initial filter for
code developed using SPARK, or in examining legacy code to see how far code developed using SPARK, or in examining legacy code to see how far
it is from meeting SPARK restrictions. it is from meeting SPARK restrictions.
@node No_Task_Termination
@unnumberedsubsec No_Task_Termination
@findex No_Task_Termination
[RM D.7] Tasks which terminate are erroneous.
@c ------------------------ @c ------------------------
@node Implementation Advice @node Implementation Advice
@chapter Implementation Advice @chapter Implementation Advice

7
gcc/ada/par-ch6.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -772,7 +772,10 @@ package body Ch6 is
(N_Expression_Function, Sloc (Specification_Node)); (N_Expression_Function, Sloc (Specification_Node));
Set_Specification (Body_Node, Specification_Node); Set_Specification (Body_Node, Specification_Node);
Set_Expression (Body_Node, P_Expression); Set_Expression (Body_Node, P_Expression);
T_Semicolon;
-- Expression functions can carry pre/postconditions
P_Aspect_Specifications (Body_Node);
Pop_Scope_Stack; Pop_Scope_Stack;
-- Subprogram body case -- Subprogram body case

11
gcc/ada/restrict.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -532,6 +532,15 @@ package body Restrict is
elsif not Restrictions.Set (R) then elsif not Restrictions.Set (R) then
null; null;
-- Don't complain about No_Obsolescent_Features in an instance, since we
-- will complain on the template, which is much better. Are there other
-- cases like this ??? Do we need a more general mechanism ???
elsif R = No_Obsolescent_Features
and then Instantiation_Location (Sloc (N)) /= No_Location
then
null;
-- Here if restriction set, check for violation (either this is a -- Here if restriction set, check for violation (either this is a
-- Boolean restriction, or a parameter restriction with a value of -- Boolean restriction, or a parameter restriction with a value of
-- zero and an unknown count, or a parameter restriction with a -- zero and an unknown count, or a parameter restriction with a

1
gcc/ada/sem_prag.adb
View File

@ -1818,6 +1818,7 @@ package body Sem_Prag is
("aspect % requires ''Class for null procedure"); ("aspect % requires ''Class for null procedure");
elsif not Nkind_In (PO, N_Subprogram_Declaration, elsif not Nkind_In (PO, N_Subprogram_Declaration,
N_Expression_Function,
N_Generic_Subprogram_Declaration, N_Generic_Subprogram_Declaration,
N_Entry_Declaration) N_Entry_Declaration)
then then