Skip to content

R
riscv-gcc-1
Commit 3bd783ec by Arnaud Charlet
Options

[multiple changes] 

2014-07-16  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document erroneous mixing of thin pointers and
	unrestricted access
	* gnat_ugn.texi: Add note on size of access types about thin
	pointers and the use of attribute Unrestricted_Access.

2014-07-16  Ed Schonberg  <schonberg@adacore.com>

	* a-cbdlli.ads, a-cbdlli.adb, a-cbhama.ads, a-cbhama.adb,
	* a-cbhase.ads, a-cbhase.adb, a-cborma.ads, a-cborma.adb,
	* a-cborse.ads, a-cborse.adb, a-cobove.ads a-cobove.adb: Add Control
	machinery to detect tampering on bounded vectors.

From-SVN: r212653
parent 473037cb
Showing with 580 additions and 76 deletions
gcc/ada/ChangeLog
2014-07-16 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document erroneous mixing of thin pointers and
unrestricted access
* gnat_ugn.texi: Add note on size of access types about thin
pointers and the use of attribute Unrestricted_Access.
2014-07-16 Ed Schonberg <schonberg@adacore.com>
* a-cbdlli.ads, a-cbdlli.adb, a-cbhama.ads, a-cbhama.adb,
* a-cbhase.ads, a-cbhase.adb, a-cborma.ads, a-cborma.adb,
* a-cborse.ads, a-cborse.adb, a-cobove.ads a-cobove.adb: Add Control
machinery to detect tampering on bounded vectors.
2014-07-16 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document that leading/trailing asterisks are
now implied for the pattern match string for pragma Warnings
and Warning_As_Error.
......
gcc/ada/a-cbdlli.adb
......@@ -228,6 +228,24 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
end Append;
------------
-- 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;
------------
-- Assign --
------------
......@@ -324,8 +342,16 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end if;
end Constant_Reference;
......@@ -545,6 +571,22 @@ package body Ada.Containers.Bounded_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 --
----------
......@@ -1672,8 +1714,16 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end if;
end Reference;
......
gcc/ada/a-cbdlli.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -284,11 +284,10 @@ private
type List_Access is access all List;
for List_Access'Storage_Size use 0;
type Cursor is
record
Container : List_Access;
Node : Count_Type := 0;
end record;
type Cursor is record
Container : List_Access;
Node : Count_Type := 0;
end record;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
......@@ -302,14 +301,21 @@ private
for Cursor'Write use Write;
type Constant_Reference_Type
(Element : not null access constant Element_Type) is null record;
type Reference_Control_Type is new Controlled with record
Container : List_Access;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type);
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
for Constant_Reference_Type'Write use Write;
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type
(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;
......@@ -317,8 +323,15 @@ private
for Constant_Reference_Type'Read use Read;
type Reference_Type
(Element : not null access Element_Type) is null record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type);
for Constant_Reference_Type'Write use Write;
type Reference_Type (Element : not null access Element_Type) is record
Control : Reference_Control_Type;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
......
gcc/ada/a-cbhama.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
......@@ -118,6 +118,24 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end "=";
------------
-- Adjust --
------------
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Map 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;
------------
-- Assign --
------------
......@@ -199,8 +217,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -217,9 +243,21 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end if;
declare
Cur : Cursor := Find (Container, Key);
pragma Unmodified (Cur);
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Cur.Container.Busy;
L : Natural renames Cur.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -446,6 +484,22 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end if;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Map 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 --
----------
......@@ -976,8 +1030,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference;
......@@ -994,8 +1057,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is
declare
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference;
......
gcc/ada/a-cbhama.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -380,8 +380,21 @@ 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;
......@@ -395,8 +408,9 @@ private
for Constant_Reference_Type'Read use Read;
type Reference_Type
(Element : not null access Element_Type) is null record;
type Reference_Type (Element : not null access Element_Type) is record
Control : Reference_Control_Type;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
......@@ -411,9 +425,10 @@ private
for Reference_Type'Read use Read;
Empty_Map : constant Map :=
(Hash_Table_Type with Capacity => 0, Modulus => 0);
(Hash_Table_Type with Capacity => 0, Modulus => 0);
No_Element : constant Cursor := (Container => null, Node => 0);
type Iterator is new Limited_Controlled and
Map_Iterator_Interfaces.Forward_Iterator with
record
......
gcc/ada/a-cbhase.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
......@@ -139,6 +139,24 @@ package body Ada.Containers.Bounded_Hashed_Sets is
end "=";
------------
-- Adjust --
------------
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Set 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;
------------
-- Assign --
------------
......@@ -217,8 +235,17 @@ package body Ada.Containers.Bounded_Hashed_Sets is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'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.Bounded_Hashed_Sets is
end if;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Set 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 --
----------
......@@ -1613,9 +1656,21 @@ package body Ada.Containers.Bounded_Hashed_Sets is
end if;
declare
Cur : Cursor := Find (Container, Key);
pragma Unmodified (Cur);
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Cur.Container.Busy;
L : Natural renames Cur.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......
gcc/ada/a-cbhase.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -444,8 +444,8 @@ package Ada.Containers.Bounded_Hashed_Sets is
Key : Key_Type) return Reference_Type;
private
type Reference_Type (Element : not null access Element_Type)
is null record;
type Reference_Type (Element : not null access Element_Type) is
null record;
use Ada.Streams;
......@@ -475,7 +475,7 @@ private
new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
type Set (Capacity : Count_Type; Modulus : Hash_Type) is
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
......@@ -518,8 +518,21 @@ 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;
......
gcc/ada/a-cborma.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
......@@ -261,6 +261,24 @@ package body Ada.Containers.Bounded_Ordered_Maps is
end ">";
------------
-- Adjust --
------------
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Map 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;
------------
-- Assign --
------------
......@@ -404,8 +422,17 @@ package body Ada.Containers.Bounded_Ordered_Maps is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -421,9 +448,21 @@ package body Ada.Containers.Bounded_Ordered_Maps is
end if;
declare
Cur : Cursor := Find (Container, Key);
pragma Unmodified (Cur);
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Cur.Container.Busy;
L : Natural renames Cur.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -595,6 +634,22 @@ package body Ada.Containers.Bounded_Ordered_Maps is
end if;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Map 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 --
----------
......@@ -1362,8 +1417,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference;
......@@ -1380,8 +1443,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is
declare
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Reference;
......
gcc/ada/a-cborma.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -228,6 +228,7 @@ package Ada.Containers.Bounded_Ordered_Maps is
private
use Ada.Finalization;
pragma Inline (Next);
pragma Inline (Previous);
......@@ -282,8 +283,21 @@ 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;
......@@ -297,8 +311,9 @@ private
for Constant_Reference_Type'Write use Write;
type Reference_Type
(Element : not null access Element_Type) is null record;
type Reference_Type (Element : not null access Element_Type) is record
Control : Reference_Control_Type;
end record;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
......@@ -316,8 +331,6 @@ private
No_Element : constant Cursor := Cursor'(null, 0);
use Ada.Finalization;
type Iterator is new Limited_Controlled and
Map_Iterator_Interfaces.Reversible_Iterator with
record
......
gcc/ada/a-cborse.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
......@@ -266,6 +266,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is
end ">";
------------
-- Adjust --
------------
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Set 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;
------------
-- Assign --
------------
......@@ -404,8 +422,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -594,6 +620,22 @@ package body Ada.Containers.Bounded_Ordered_Sets is
end if;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Set 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 --
----------
......@@ -720,9 +762,21 @@ package body Ada.Containers.Bounded_Ordered_Sets is
end if;
declare
Cur : Cursor := Find (Container, Key);
pragma Unmodified (Cur);
N : Node_Type renames Container.Nodes (Node);
B : Natural renames Cur.Container.Busy;
L : Natural renames Cur.Container.Lock;
begin
return (Element => N.Element'Access);
return R : constant Constant_Reference_Type :=
(Element => N.Element'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......
gcc/ada/a-cborse.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -277,8 +277,8 @@ package Ada.Containers.Bounded_Ordered_Sets is
Key : Key_Type) return Reference_Type;
private
type Reference_Type
(Element : not null access Element_Type) is null record;
type Reference_Type (Element : not null access Element_Type) is
null record;
use Ada.Streams;
......@@ -316,6 +316,7 @@ private
new Tree_Types.Tree_Type (Capacity) with null record;
use Tree_Types;
use Ada.Finalization;
use Ada.Streams;
procedure Write
......@@ -356,8 +357,21 @@ 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;
......@@ -375,8 +389,6 @@ private
No_Element : constant Cursor := Cursor'(null, 0);
use Ada.Finalization;
type Iterator is new Limited_Controlled and
Set_Iterator_Interfaces.Reversible_Iterator with
record
......
gcc/ada/a-cobove.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
......@@ -315,6 +315,24 @@ package body Ada.Containers.Bounded_Vectors is
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;
------------
-- Assign --
------------
......@@ -418,8 +436,16 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Position.Index);
B : Natural renames Position.Container.Busy;
L : Natural renames Position.Container.Lock;
begin
return (Element => A (I)'Access);
return R : constant Constant_Reference_Type :=
(Element => A (I)'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference;
......@@ -436,7 +462,13 @@ package body Ada.Containers.Bounded_Vectors is
A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Index);
begin
return (Element => A (I)'Access);
return R : constant Constant_Reference_Type :=
(Element => A (I)'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
R.Control.Container.Busy := R.Control.Container.Busy + 1;
R.Control.Container.Lock := R.Control.Container.Lock + 1;
end return;
end;
end Constant_Reference;
......@@ -731,6 +763,22 @@ package body Ada.Containers.Bounded_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 --
----------
......@@ -2317,9 +2365,14 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
J : constant Count_Type := To_Array_Index (Position.Index);
begin
return (Element => A (J)'Access);
B := B + 1;
L := L + 1;
return (Element => A (J)'Access,
Control => (Controlled with Container'Unrestricted_Access));
end;
end Reference;
......@@ -2334,9 +2387,14 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
J : constant Count_Type := To_Array_Index (Index);
begin
return (Element => A (J)'Access);
B := B + 1;
L := L + 1;
return (Element => A (J)'Access,
Control => (Controlled with Container'Unrestricted_Access));
end;
end Reference;
......
gcc/ada/a-cobove.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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 --
......@@ -409,8 +409,21 @@ private
for Cursor'Read use Read;
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 Read
(Stream : not null access Root_Stream_Type'Class;
......@@ -424,8 +437,9 @@ private
for Constant_Reference_Type'Write use Write;
type Reference_Type
(Element : not null access Element_Type) is null record;
type Reference_Type (Element : not null access Element_Type) is record
Control : Reference_Control_Type;
end record;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
......
gcc/ada/gnat_rm.texi
......@@ -9470,16 +9470,16 @@ corresponding actual subtype. The value of this attribute is of type
@code{System.Aux_DEC.Type_Class}, which has the following definition:
@smallexample @c ada
type Type_Class is
(Type_Class_Enumeration,
Type_Class_Integer,
Type_Class_Fixed_Point,
Type_Class_Floating_Point,
Type_Class_Array,
Type_Class_Record,
Type_Class_Access,
Type_Class_Task,
Type_Class_Address);
type Type_Class is
(Type_Class_Enumeration,
Type_Class_Integer,
Type_Class_Fixed_Point,
Type_Class_Floating_Point,
Type_Class_Array,
Type_Class_Record,
Type_Class_Access,
Type_Class_Task,
Type_Class_Address);
@end smallexample
@noindent
......@@ -9541,7 +9541,7 @@ The @code{Unrestricted_Access} attribute is similar to @code{Access}
except that all accessibility and aliased view checks are omitted. This
is a user-beware attribute. It is similar to
@code{Address}, for which it is a desirable replacement where the value
desired is an access type. In other words, its effect is identical to
desired is an access type. In other words, its effect is similar to
first applying the @code{Address} attribute and then doing an unchecked
conversion to a desired access type. In GNAT, but not necessarily in
other implementations, the use of static chains for inner level
......@@ -9550,12 +9550,58 @@ subprogram yields a value that can be called as long as the subprogram
is in scope (normal Ada accessibility rules restrict this usage).
It is possible to use @code{Unrestricted_Access} for any type, but care
must be exercised if it is used to create pointers to unconstrained
must be exercised if it is used to create pointers to unconstrained array
objects. In this case, the resulting pointer has the same scope as the
context of the attribute, and may not be returned to some enclosing
scope. For instance, a function cannot use @code{Unrestricted_Access}
to create a unconstrained pointer and then return that value to the
caller.
caller. In addition, it is only valid to create pointers to unconstrained
arrays using this attribute if the pointer has the normal default ``fat''
representation where a pointer has two components, one points to the array
and one points to the bounds. If a size clause is used to force ``thin''
representation for a pointer to unconstrained where there is only space for
a single pointer, then any use of @code{Unrestricted_Access}
to create a value of such a type (e.g. by conversion from fat to
thin pointers) is erroneous. Consider the following example:
@smallexample @c ada
with System; use System;
procedure SliceUA is
type A is access all String;
for A'Size use Standard'Address_Size;
procedure P (Arg : A) is
begin
if Arg'Length /= 6 then
raise Program_Error;
end if;
end P;
X : String := "hello world!";
begin
P (X(7 .. 12)'Unrestricted_Access);
end;
@end smallexample
@noindent
This inevitably raises @code{Program_Error}.
A normal unconstrained array value
or a constrained array object marked as aliased has the bounds in memory
just before the array, so a thin pointer can retrieve both the data and
the bounds. But in this case, the non-aliased object @code{X} does not have the
bounds before the string. If the size clause for type @code{A}
were not present, then the pointer
would be a fat pointer, where one component is a pointer to the bounds,
and all would be well. But with the size clause present, the conversion from
fat pointer to think pointer in the call looses the bounds.
In general, it is advisable to completely
avoid mixing the use of thin pointers and the use of
@code{Unrestricted_Access} where the designated type is an
unconstrained array. The use of thin pointers should be restricted to
cases of porting legacy code which implicitly assumes the size of pointers,
and such code should not in any case be using this attribute.
@node Attribute Update
@unnumberedsec Attribute Update
......
gcc/ada/gnat_ugn.texi
......@@ -29185,6 +29185,10 @@ a functionally correct manner and allow porting of existing code.
Note that another way of forcing a thin pointer representation
is to use a component size clause for the element size in an array,
or a record representation clause for an access field in a record.
See the documentation of Unrestricted_Access in the GNAT RM for a
full discussion of possible problems using this attribute in conjunction
with thin pointers.
@end table
@ifclear vms
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment