OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests 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>
* 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 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 --
------------
@ -244,7 +258,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
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;
--------------
@ -442,6 +469,22 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
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 --
----------
@ -1336,7 +1379,19 @@ package body Ada.Containers.Doubly_Linked_Lists is
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;
---------------------

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

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

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

@ -166,6 +166,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end loop;
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 --
------------
@ -271,7 +285,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
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;
--------------
@ -479,6 +505,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
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 --
----------
@ -1372,7 +1414,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
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;
---------------------

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

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

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -217,7 +232,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Vet (Position),
"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;
function Constant_Reference
@ -235,7 +264,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Program_Error with "key has no element";
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;
--------------
@ -484,6 +527,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
end if;
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 --
----------
@ -1028,7 +1088,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Vet (Position),
"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;
function Reference
@ -1046,7 +1119,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
raise Program_Error with "key has no element";
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;
-------------

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

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

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -228,7 +242,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
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;
--------------
@ -610,6 +637,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
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 --
----------
@ -1926,7 +1969,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
raise Program_Error with "Node has no element";
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;
--------------

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

@ -152,6 +152,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
@ -507,8 +508,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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;
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 --
-------------------
@ -472,7 +486,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
-- pragma Assert (Vet (Position),
-- "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;
--------------
@ -985,6 +1012,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
----------
-- Find --
----------
@ -2041,7 +2084,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
-- pragma Assert (Vet (Position),
-- "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;
--------------------

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
(Container : aliased Tree;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Tree;
Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Tree; Source : Tree);
@ -378,8 +380,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;
@ -394,7 +410,10 @@ private
for Constant_Reference_Type'Write use Write;
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
(Stream : not null access Root_Stream_Type'Class;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -379,7 +393,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node),
"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;
function Constant_Reference
@ -397,7 +424,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
raise Program_Error with "Node has no element";
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;
--------------
@ -586,6 +626,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
end if;
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 --
----------
@ -1360,7 +1416,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node),
"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;
function Reference
@ -1378,7 +1446,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
raise Program_Error with "Node has no element";
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;
-------------

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

@ -109,18 +109,22 @@ package Ada.Containers.Indefinite_Ordered_Maps is
function Constant_Reference
(Container : aliased Map;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Map;
Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Map;
Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map);
@ -292,8 +296,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;
@ -308,7 +326,10 @@ private
for Constant_Reference_Type'Write use Write;
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
(Stream : not null access Root_Stream_Type'Class;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -398,7 +412,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Vet (Container.Tree, Position.Node),
"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;
--------------
@ -617,6 +644,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
end if;
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 --
----------
@ -782,7 +825,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
raise Program_Error with "Node has no element";
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;
--------------

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

@ -99,6 +99,7 @@ package Ada.Containers.Indefinite_Ordered_Sets is
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
@ -376,8 +377,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -211,7 +225,19 @@ package body Ada.Containers.Hashed_Maps is
(Vet (Position),
"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;
function Constant_Reference
@ -225,7 +251,20 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error with "key not in map";
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;
--------------
@ -439,6 +478,22 @@ package body Ada.Containers.Hashed_Maps is
end if;
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 --
----------
@ -920,7 +975,19 @@ package body Ada.Containers.Hashed_Maps is
(Vet (Position),
"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;
function Reference
@ -934,7 +1001,20 @@ package body Ada.Containers.Hashed_Maps is
raise Constraint_Error with "key not in map";
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;
---------------

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

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

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -218,7 +232,20 @@ package body Ada.Containers.Hashed_Sets is
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;
--------------
@ -548,6 +575,22 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Finalize (Container.HT);
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 --
----------
@ -1746,7 +1789,20 @@ package body Ada.Containers.Hashed_Sets is
raise Constraint_Error with "Key not in set";
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;
--------------

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

@ -153,6 +153,7 @@ package Ada.Containers.Hashed_Sets is
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
@ -509,8 +510,22 @@ private
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
(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
(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 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 --
------------
@ -697,7 +711,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Position is empty";
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;
function Constant_Reference
@ -717,7 +744,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Index is empty";
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;
--------------
@ -1131,6 +1171,22 @@ package body Ada.Containers.Indefinite_Vectors is
B := B - 1;
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 --
----------
@ -1402,6 +1458,8 @@ package body Ada.Containers.Indefinite_Vectors is
Array_Type => Elements_Array,
"<" => Is_Less);
-- Start of processing for Sort
begin
if Container.Last <= Index_Type'First then
return;
@ -3047,7 +3105,19 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Position is empty";
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;
function Reference
@ -3067,7 +3137,20 @@ package body Ada.Containers.Indefinite_Vectors is
raise Constraint_Error with "element at Index is empty";
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;
---------------------
@ -3430,9 +3513,9 @@ package body Ada.Containers.Indefinite_Vectors is
-- catch more things) instead of for element tampering (which will catch
-- fewer things). It's true that the elements of this vector container
-- could be safely moved around while (say) an iteration is taking place
-- (iteration only increments the busy counter), and so technically
-- all we would need here is a test for element tampering (indicated
-- by the lock counter), that's simply an artifact of our array-based
-- (iteration only increments the busy counter), and so technically all
-- we would need here is a test for element tampering (indicated by the
-- lock counter), that's simply an artifact of our array-based
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.

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

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

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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;
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 --
-------------------
@ -464,7 +478,20 @@ package body Ada.Containers.Multiway_Trees is
-- pragma Assert (Vet (Position),
-- "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;
--------------
@ -957,6 +984,22 @@ package body Ada.Containers.Multiway_Trees is
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Tree renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize;
----------
-- Find --
----------
@ -2053,7 +2096,19 @@ package body Ada.Containers.Multiway_Trees is
-- pragma Assert (Vet (Position),
-- "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;
--------------------

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -111,10 +111,12 @@ package Ada.Containers.Multiway_Trees is
function Constant_Reference
(Container : aliased Tree;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Tree;
Position : Cursor) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Tree; Source : Tree);
@ -423,8 +425,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;
@ -439,7 +455,10 @@ private
for Constant_Reference_Type'Write use Write;
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
(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 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 --
------------
@ -499,7 +513,21 @@ package body Ada.Containers.Vectors is
raise Constraint_Error with "Position cursor is out of range";
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;
function Constant_Reference
@ -510,7 +538,20 @@ package body Ada.Containers.Vectors is
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
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 Constant_Reference;
@ -825,6 +866,22 @@ package body Ada.Containers.Vectors is
B := B - 1;
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 --
----------
@ -2601,7 +2658,20 @@ package body Ada.Containers.Vectors is
raise Constraint_Error with "Position cursor is out of range";
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;
function Reference
@ -2612,7 +2682,20 @@ package body Ada.Containers.Vectors is
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
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 Reference;

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

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

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -340,7 +354,19 @@ package body Ada.Containers.Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node),
"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;
function Constant_Reference
@ -354,7 +380,20 @@ package body Ada.Containers.Ordered_Maps is
raise Constraint_Error with "key not in map";
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;
--------------
@ -532,6 +571,22 @@ package body Ada.Containers.Ordered_Maps is
end if;
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 --
----------
@ -1294,7 +1349,19 @@ package body Ada.Containers.Ordered_Maps is
pragma Assert (Vet (Container.Tree, Position.Node),
"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;
function Reference
@ -1308,7 +1375,20 @@ package body Ada.Containers.Ordered_Maps is
raise Constraint_Error with "key not in map";
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;
-------------

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

@ -108,18 +108,22 @@ package Ada.Containers.Ordered_Maps is
function Constant_Reference
(Container : aliased Map;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Map;
Position : Cursor) return Reference_Type;
pragma Inline (Reference);
function Constant_Reference
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out Map;
Key : Key_Type) return Reference_Type;
pragma Inline (Reference);
procedure Assign (Target : in out Map; Source : Map);
@ -293,8 +297,22 @@ private
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
(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
(Stream : not null access Root_Stream_Type'Class;
@ -309,7 +327,10 @@ private
for Constant_Reference_Type'Write use Write;
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
(Stream : not null access Root_Stream_Type'Class;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
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 --
------------
@ -353,7 +367,20 @@ package body Ada.Containers.Ordered_Sets is
(Vet (Container.Tree, Position.Node),
"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;
--------------
@ -554,6 +581,22 @@ package body Ada.Containers.Ordered_Sets is
end if;
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 --
----------
@ -699,7 +742,20 @@ package body Ada.Containers.Ordered_Sets is
raise Constraint_Error with "key not in set";
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;
--------------

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

@ -100,6 +100,7 @@ package Ada.Containers.Ordered_Sets is
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
@ -359,8 +360,22 @@ private
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
(Element : not null access constant Element_Type) is null record;
(Element : not null access constant Element_Type) is
record
Control : Reference_Control_Type;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;

1
gcc/ada/aspects.adb
View File

@ -193,6 +193,7 @@ package body Aspects is
N_Entry_Declaration => True,
N_Exception_Declaration => True,
N_Exception_Renaming_Declaration => True,
N_Expression_Function => True,
N_Formal_Abstract_Subprogram_Declaration => True,
N_Formal_Concrete_Subprogram_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);
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);
end Find_Finalize_Address;

14
gcc/ada/gnat_rm.texi
View File

@ -355,6 +355,7 @@ Partition-Wide Restrictions
* No_Task_Allocators::
* No_Task_Attributes_Package::
* No_Task_Hierarchy::
* No_Task_Termination::
* No_Tasking::
* No_Terminate_Alternatives::
* No_Unchecked_Access::
@ -376,7 +377,6 @@ Program Unit Level Restrictions
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK::
* No_Task_Termination::
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_Attributes_Package::
* No_Task_Hierarchy::
* No_Task_Termination::
* No_Tasking::
* No_Terminate_Alternatives::
* No_Unchecked_Access::
@ -7541,6 +7542,11 @@ explicit dependencies on the package @code{Ada.Task_Attributes}.
[RM D.7] All (non-environment) tasks depend
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
@unnumberedsubsec No_Tasking
@findex No_Tasking
@ -7605,7 +7611,6 @@ other compilation units in the partition.
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK::
* No_Task_Termination::
@end menu
@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
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 ------------------------
@node Implementation Advice
@chapter Implementation Advice

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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));
Set_Specification (Body_Node, Specification_Node);
Set_Expression (Body_Node, P_Expression);
T_Semicolon;
-- Expression functions can carry pre/postconditions
P_Aspect_Specifications (Body_Node);
Pop_Scope_Stack;
-- Subprogram body case

11
gcc/ada/restrict.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
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
-- Boolean restriction, or a parameter restriction with a value of
-- 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");
elsif not Nkind_In (PO, N_Subprogram_Declaration,
N_Expression_Function,
N_Generic_Subprogram_Declaration,
N_Entry_Declaration)
then