diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 14 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.ads | 41 | ||||
| -rw-r--r-- | gcc/ada/a-cbhama.adb | 82 | ||||
| -rw-r--r-- | gcc/ada/a-cbhama.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/a-cbhase.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/a-cbhase.ads | 23 | ||||
| -rw-r--r-- | gcc/ada/a-cborma.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/a-cborma.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/a-cborse.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/a-cobove.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/a-cobove.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 72 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 4 |
15 files changed, 580 insertions, 76 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index abee07f..feff3ff 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,19 @@ 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. diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index d0b6c12..796d87b 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/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; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index 291c1e0..d7a1f49 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/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; diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index e7e7393..eb53e75 100644 --- a/gcc/ada/a-cbhama.adb +++ b/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; diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads index 076fac2..a87c1e9 100644 --- a/gcc/ada/a-cbhama.ads +++ b/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 diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 640fb8e..6ea8e0a 100644 --- a/gcc/ada/a-cbhase.adb +++ b/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; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index 5de5d28..40eea2f 100644 --- a/gcc/ada/a-cbhase.ads +++ b/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; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index 4b05726..68b6bef 100644 --- a/gcc/ada/a-cborma.adb +++ b/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; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index 2c2a8a5..d028682 100644 --- a/gcc/ada/a-cborma.ads +++ b/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 diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index baeedba..ea6a6d0 100644 --- a/gcc/ada/a-cborse.adb +++ b/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; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index d22ef54..03fdd49 100644 --- a/gcc/ada/a-cborse.ads +++ b/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 diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 28f6f4d..a7e7a76 100644 --- a/gcc/ada/a-cobove.adb +++ b/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; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 267c64d..862076a 100644 --- a/gcc/ada/a-cobove.ads +++ b/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; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 166a6cc..8f1031a 100644 --- a/gcc/ada/gnat_rm.texi +++ b/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 diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6a62aa7..a8c84f0 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/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 |