+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.
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 --
------------
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 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 --
----------
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;
---------------------
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);
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;
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;
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 --
------------
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 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 --
----------
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;
---------------------
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);
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;
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;
-- --
-- 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- --
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 --
------------
(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
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;
--------------
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 --
----------
(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
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;
-------------
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);
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;
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;
-- --
-- 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- --
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 --
------------
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 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 --
----------
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;
--------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
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;
-- --
-- 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- --
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 --
-------------------
-- 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;
--------------
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 --
----------
-- 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;
--------------------
-- --
-- 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 --
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);
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;
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;
-- --
-- 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- --
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 --
------------
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
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;
--------------
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 --
----------
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
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;
-------------
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);
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;
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;
-- --
-- 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- --
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 --
------------
(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;
--------------
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 --
----------
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;
--------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
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;
-- --
-- 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- --
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 --
------------
(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
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;
--------------
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 --
----------
(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
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;
---------------
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);
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;
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;
-- --
-- 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- --
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 --
------------
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;
--------------
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 --
----------
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;
--------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
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;
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 --
------------
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
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;
--------------
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 --
----------
Array_Type => Elements_Array,
"<" => Is_Less);
+ -- Start of processing for Sort
+
begin
if Container.Last <= Index_Type'First then
return;
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
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;
---------------------
-- 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.
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;
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;
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;
-- --
-- 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- --
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 --
-------------------
-- 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;
--------------
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 --
----------
-- 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;
--------------------
-- --
-- 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 --
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);
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;
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;
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 --
------------
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
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;
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 --
----------
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
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;
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);
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;
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;
-- --
-- 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- --
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 --
------------
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
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;
--------------
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 --
----------
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
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;
-------------
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);
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;
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;
-- --
-- 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- --
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 --
------------
(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;
--------------
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 --
----------
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;
--------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
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;
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,
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;
* No_Task_Allocators::
* No_Task_Attributes_Package::
* No_Task_Hierarchy::
+* No_Task_Termination::
* No_Tasking::
* No_Terminate_Alternatives::
* No_Unchecked_Access::
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK::
-* No_Task_Termination::
The Implementation of Standard I/O
* No_Task_Allocators::
* No_Task_Attributes_Package::
* No_Task_Hierarchy::
+* No_Task_Termination::
* No_Tasking::
* No_Terminate_Alternatives::
* No_Unchecked_Access::
[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
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK::
-* No_Task_Termination::
@end menu
@node No_Elaboration_Code
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
-- --
-- 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- --
(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
-- --
-- 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- --
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
("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
projects / gcc.git / commitdiff