diff options
35 files changed, 1350 insertions, 89 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9f164bf391e..a7e3dee1d92 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2012-02-17 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi: Minor shuffling. + +2012-02-17 Ed Schonberg <schonberg@adacore.com> + + * aspects.adb: Expression functions can carry pre/postconditions. + * par-ch6.adb (P_Subprogram): look for optional pre/postconditions + in an expression function. + * sem_prag (Check_Precondition_Postcondition): legal on expression + functions. + +2012-02-17 Vincent Pucci <pucci@adacore.com> + + * a-cdlili.adb, a-cidlli.adb, a-cihama.adb, a-cimutr.adb, + * a-ciorma.adb, a-cohama.adb, a-coinve.adb, a-comutr.adb, + * a-convec.adb, a-coorma.adb (Adjust): New routine. + (Constant_Reference): Increment Busy and Lock counters. + (Reference): Increase Busy and Lock counters. + (Finalize): New routine. + * a-cihase.adb, a-ciorse.adb, a-cohase.adb, a-coorse.adb: + (Adjust): New routine. (Constant_Reference): Increment Busy + and Lock counters. + (Finalize): New routine. + * a-cdlili.ads, a-cidlli.ads, a-cihama.ads, a-cihase.ads, + * a-cimutr.ads, a-ciorma.ads, a-ciorse.ads, a-cohama.ads, + * a-cohase.ads, a-coinve.ads, a-comutr.ads, a-convec.ads, + * a-coorma.ads, a-coorse: Controlled component added to the + reference types. + +2012-02-17 Robert Dewar <dewar@adacore.com> + + * restrict.adb (Check_Restriction): Add special handling for + No_Obsolescent_Features. + +2012-02-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Find_Finalize_Address): When dealing with an + internally built full view for a type with unknown discriminants, + use the original record type. + 2012-02-17 Robert Dewar <dewar@adacore.com> * sem_dim.adb: Minor reformatting. diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index cfbcc36bc79..a04afb0bd8f 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -142,6 +142,20 @@ package body Ada.Containers.Doubly_Linked_Lists is end loop; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : List renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Append -- ------------ @@ -244,7 +258,20 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element'Access); + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -442,6 +469,22 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : List renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1336,7 +1379,19 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in function Reference"); - return (Element => Position.Node.Element'Access); + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; --------------------- diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index ae9ae6b625a..d1707c757a2 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -104,10 +104,12 @@ package Ada.Containers.Doubly_Linked_Lists is function Constant_Reference (Container : aliased List; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out List; Position : Cursor) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out List; Source : List); @@ -305,8 +307,22 @@ private for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : List_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -321,7 +337,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index cac6e9cafa6..cc93b4c2fc0 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -166,6 +166,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end loop; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : List renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Append -- ------------ @@ -271,7 +285,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element.all'Access); + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -479,6 +505,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : List renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1372,7 +1414,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in function Reference"); - return (Element => Position.Node.Element.all'Access); + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; --------------------- diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 37886e1538f..af57af11ae9 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -103,10 +103,12 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is function Constant_Reference (Container : aliased List; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out List; Position : Cursor) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out List; Source : List); @@ -299,8 +301,22 @@ private for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : List_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -315,7 +331,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 35419020c10..1d30d0443e4 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -136,6 +136,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + M : Map renames Control.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -217,7 +232,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is (Vet (Position), "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -235,7 +264,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Program_Error with "key has no element"; end if; - return (Element => Node.Element.all'Access); + declare + M : Map renames Container'Unrestricted_Access.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -484,6 +527,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + M : Map renames Control.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1028,7 +1088,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is (Vet (Position), "Position cursor in function Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -1046,7 +1119,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Program_Error with "key has no element"; end if; - return (Element => Node.Element.all'Access); + declare + M : Map renames Container'Unrestricted_Access.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; ------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index f2158fdc79c..feef181b65b 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -147,18 +147,22 @@ package Ada.Containers.Indefinite_Hashed_Maps is function Constant_Reference (Container : aliased Map; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Key : Key_Type) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Map; Source : Map); @@ -363,8 +367,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Map_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -379,7 +397,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 6255675550e..735179415c1 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -165,6 +165,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -228,7 +242,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element.all'Access); + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -610,6 +637,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1926,7 +1969,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise Program_Error with "Node has no element"; end if; - return (Element => Node.Element.all'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index f361830b78b..b300186f6db 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -152,6 +152,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Constant_Reference (Container : aliased Set; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); procedure Assign (Target : in out Set; Source : Set); @@ -507,8 +508,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Set_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index c3887a57769..050c0395dee 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -204,6 +204,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Container.Count := Source_Count; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------------- -- Ancestor_Find -- ------------------- @@ -472,7 +486,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -985,6 +1012,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2041,7 +2084,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; -------------------- diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 87c0e41f1d5..6c3411f1314 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -112,10 +112,12 @@ package Ada.Containers.Indefinite_Multiway_Trees is function Constant_Reference (Container : aliased Tree; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Tree; Position : Cursor) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Tree; Source : Tree); @@ -378,8 +380,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Tree_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; @@ -394,7 +410,10 @@ private for Constant_Reference_Type'Write use Write; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 15efbc7243d..b62b87b3a39 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -291,6 +291,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Adjust (Container.Tree); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + T : Tree_Type renames Control.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -379,7 +393,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -397,7 +424,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is raise Program_Error with "Node has no element"; end if; - return (Element => Node.Element.all'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -586,6 +626,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + T : Tree_Type renames Control.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1360,7 +1416,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor in function Reference is bad"); - return (Element => Position.Node.Element.all'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -1378,7 +1446,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is raise Program_Error with "Node has no element"; end if; - return (Element => Node.Element.all'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; ------------- diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 7599b3e6dbb..5c3a776c4aa 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -109,18 +109,22 @@ package Ada.Containers.Indefinite_Ordered_Maps is function Constant_Reference (Container : aliased Map; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Key : Key_Type) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Map; Source : Map); @@ -292,8 +296,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Map_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; @@ -308,7 +326,10 @@ private for Constant_Reference_Type'Write use Write; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index ff929067237..7b919494a17 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -325,6 +325,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Adjust (Container.Tree); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -398,7 +412,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Vet (Container.Tree, Position.Node), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element.all'Access); + declare + Tree : Tree_Type renames Position.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -617,6 +644,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -782,7 +825,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "Node has no element"; end if; - return (Element => Node.Element.all'Access); + declare + Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index aa16272ed11..87ba353e9e8 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -99,6 +99,7 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Constant_Reference (Container : aliased Set; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); procedure Assign (Target : in out Set; Source : Set); @@ -376,8 +377,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Set_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 8adcb1af35a..00553d0eeff 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -135,6 +135,20 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -211,7 +225,19 @@ package body Ada.Containers.Hashed_Maps is (Vet (Position), "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -225,7 +251,20 @@ package body Ada.Containers.Hashed_Maps is raise Constraint_Error with "key not in map"; end if; - return (Element => Node.Element'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -439,6 +478,22 @@ package body Ada.Containers.Hashed_Maps is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -920,7 +975,19 @@ package body Ada.Containers.Hashed_Maps is (Vet (Position), "Position cursor in function Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -934,7 +1001,20 @@ package body Ada.Containers.Hashed_Maps is raise Constraint_Error with "key not in map"; end if; - return (Element => Node.Element'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; --------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 6550b46a1a1..98b2cb3c5a8 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -148,18 +148,22 @@ package Ada.Containers.Hashed_Maps is function Constant_Reference (Container : aliased Map; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Key : Key_Type) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Map; Source : Map); @@ -369,8 +373,22 @@ private for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : Map_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -385,7 +403,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index dd09da5a17c..11940ee7a57 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -161,6 +161,20 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -218,7 +232,20 @@ package body Ada.Containers.Hashed_Sets is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element'Access); + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -548,6 +575,22 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1746,7 +1789,20 @@ package body Ada.Containers.Hashed_Sets is raise Constraint_Error with "Key not in set"; end if; - return (Element => Node.Element'Access); + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 88b5f4bfb43..de62cd96a5f 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -153,6 +153,7 @@ package Ada.Containers.Hashed_Sets is function Constant_Reference (Container : aliased Set; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); procedure Assign (Target : in out Set; Source : Set); @@ -509,8 +510,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Set_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 326524cc2f1..0627af1b94e 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -578,6 +578,20 @@ package body Ada.Containers.Indefinite_Vectors is end; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Vector renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Append -- ------------ @@ -697,7 +711,20 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "element at Position is empty"; end if; - return (Element => E.all'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => E.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -717,7 +744,20 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "element at Index is empty"; end if; - return (Element => E.all'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => E.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -1131,6 +1171,22 @@ package body Ada.Containers.Indefinite_Vectors is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Vector renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1402,6 +1458,8 @@ package body Ada.Containers.Indefinite_Vectors is Array_Type => Elements_Array, "<" => Is_Less); + -- Start of processing for Sort + begin if Container.Last <= Index_Type'First then return; @@ -3047,7 +3105,19 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "element at Position is empty"; end if; - return (Element => E.all'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => E.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -3067,7 +3137,20 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error with "element at Index is empty"; end if; - return (Element => E.all'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => E.all'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; --------------------- @@ -3430,9 +3513,9 @@ package body Ada.Containers.Indefinite_Vectors is -- catch more things) instead of for element tampering (which will catch -- fewer things). It's true that the elements of this vector container -- could be safely moved around while (say) an iteration is taking place - -- (iteration only increments the busy counter), and so technically - -- all we would need here is a test for element tampering (indicated - -- by the lock counter), that's simply an artifact of our array-based + -- (iteration only increments the busy counter), and so technically all + -- we would need here is a test for element tampering (indicated by the + -- lock counter), that's simply an artifact of our array-based -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index e060c0cb038..c9a64989be5 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -117,18 +117,22 @@ package Ada.Containers.Indefinite_Vectors is function Constant_Reference (Container : aliased Vector; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Vector; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Vector; Index : Index_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Vector; Index : Index_Type) return Reference_Type; + pragma Inline (Reference); function To_Cursor (Container : Vector; @@ -408,8 +412,22 @@ private for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : Vector_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -424,7 +442,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index a923871b148..4933bcf54a9 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -206,6 +206,20 @@ package body Ada.Containers.Multiway_Trees is Container.Count := Source_Count; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------------- -- Ancestor_Find -- ------------------- @@ -464,7 +478,20 @@ package body Ada.Containers.Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -957,6 +984,22 @@ package body Ada.Containers.Multiway_Trees is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2053,7 +2096,19 @@ package body Ada.Containers.Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; -------------------- diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index 20a91bb9a13..6e0aa9a1203 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -111,10 +111,12 @@ package Ada.Containers.Multiway_Trees is function Constant_Reference (Container : aliased Tree; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Tree; Position : Cursor) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Tree; Source : Tree); @@ -423,8 +425,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Tree_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; @@ -439,7 +455,10 @@ private for Constant_Reference_Type'Write use Write; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 729fead732c..709e1fe7e90 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -396,6 +396,20 @@ package body Ada.Containers.Vectors is end; end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Vector renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Append -- ------------ @@ -499,7 +513,21 @@ package body Ada.Containers.Vectors is raise Constraint_Error with "Position cursor is out of range"; end if; - return (Element => Container.Elements.EA (Position.Index)'Access); + declare + C : Vector renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => + Container.Elements.EA (Position.Index)'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -510,7 +538,20 @@ package body Ada.Containers.Vectors is if Index > Container.Last then raise Constraint_Error with "Index is out of range"; else - return (Element => Container.Elements.EA (Index)'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end if; end Constant_Reference; @@ -825,6 +866,22 @@ package body Ada.Containers.Vectors is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Vector renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2601,7 +2658,20 @@ package body Ada.Containers.Vectors is raise Constraint_Error with "Position cursor is out of range"; end if; - return (Element => Container.Elements.EA (Position.Index)'Access); + declare + C : Vector renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => + Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -2612,7 +2682,20 @@ package body Ada.Containers.Vectors is if Index > Container.Last then raise Constraint_Error with "Index is out of range"; else - return (Element => Container.Elements.EA (Index)'Access); + declare + C : Vector renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end if; end Reference; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 6ed39a40450..81d1a18d062 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -158,18 +158,22 @@ package Ada.Containers.Vectors is function Constant_Reference (Container : aliased Vector; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Vector; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Vector; Index : Index_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Vector; Index : Index_Type) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Vector; Source : Vector); @@ -416,8 +420,22 @@ private for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : Vector_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -432,7 +450,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index c7153c5fcbb..0e72d69e315 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -252,6 +252,20 @@ package body Ada.Containers.Ordered_Maps is Adjust (Container.Tree); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + T : Tree_Type renames Control.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -340,7 +354,19 @@ package body Ada.Containers.Ordered_Maps is pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor in Constant_Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + T : Tree_Type renames Position.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; function Constant_Reference @@ -354,7 +380,20 @@ package body Ada.Containers.Ordered_Maps is raise Constraint_Error with "key not in map"; end if; - return (Element => Node.Element'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -532,6 +571,22 @@ package body Ada.Containers.Ordered_Maps is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + T : Tree_Type renames Control.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1294,7 +1349,19 @@ package body Ada.Containers.Ordered_Maps is pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor in function Reference is bad"); - return (Element => Position.Node.Element'Access); + declare + T : Tree_Type renames Position.Container.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; function Reference @@ -1308,7 +1375,20 @@ package body Ada.Containers.Ordered_Maps is raise Constraint_Error with "key not in map"; end if; - return (Element => Node.Element'Access); + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference; ------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 61a762ea189..d9281faccc3 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -108,18 +108,22 @@ package Ada.Containers.Ordered_Maps is function Constant_Reference (Container : aliased Map; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Position : Cursor) return Reference_Type; + pragma Inline (Reference); function Constant_Reference (Container : aliased Map; Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); function Reference (Container : aliased in out Map; Key : Key_Type) return Reference_Type; + pragma Inline (Reference); procedure Assign (Target : in out Map; Source : Map); @@ -293,8 +297,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Map_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; @@ -309,7 +327,10 @@ private for Constant_Reference_Type'Write use Write; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 41ebb5c0d71..600403b1e4d 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -285,6 +285,20 @@ package body Ada.Containers.Ordered_Sets is Adjust (Container.Tree); end Adjust; + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------ -- Assign -- ------------ @@ -353,7 +367,20 @@ package body Ada.Containers.Ordered_Sets is (Vet (Container.Tree, Position.Node), "bad cursor in Constant_Reference"); - return (Element => Position.Node.Element'Access); + declare + Tree : Tree_Type renames Position.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -554,6 +581,22 @@ package body Ada.Containers.Ordered_Sets is end if; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -699,7 +742,20 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error with "key not in set"; end if; - return (Element => Node.Element'Access); + declare + Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 540da1a697d..e28a71bc299 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -100,6 +100,7 @@ package Ada.Containers.Ordered_Sets is function Constant_Reference (Container : aliased Set; Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); procedure Assign (Target : in out Set; Source : Set); @@ -359,8 +360,22 @@ private for Cursor'Read use Read; + type Reference_Control_Type is + new Controlled with record + Container : Set_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 69a789cc829..89af1d975f3 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -193,6 +193,7 @@ package body Aspects is N_Entry_Declaration => True, N_Exception_Declaration => True, N_Exception_Renaming_Declaration => True, + N_Expression_Function => True, N_Formal_Abstract_Subprogram_Declaration => True, N_Formal_Concrete_Subprogram_Declaration => True, N_Formal_Object_Declaration => True, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 41bfa382fea..98bd2f3b491 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -483,6 +483,13 @@ package body Exp_Util is Utyp := Base_Type (Utyp); end if; + -- When dealing with an internally built full view for a type with + -- unknown discriminants, use the original record type. + + if Is_Underlying_Record_View (Utyp) then + Utyp := Etype (Utyp); + end if; + return TSS (Utyp, TSS_Finalize_Address); end Find_Finalize_Address; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 1d259949601..9b10794e5c9 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -355,6 +355,7 @@ Partition-Wide Restrictions * No_Task_Allocators:: * No_Task_Attributes_Package:: * No_Task_Hierarchy:: +* No_Task_Termination:: * No_Tasking:: * No_Terminate_Alternatives:: * No_Unchecked_Access:: @@ -376,7 +377,6 @@ Program Unit Level Restrictions * No_Obsolescent_Features:: * No_Wide_Characters:: * SPARK:: -* No_Task_Termination:: The Implementation of Standard I/O @@ -6993,6 +6993,7 @@ then all compilation units in the partition must obey the restriction). * No_Task_Allocators:: * No_Task_Attributes_Package:: * No_Task_Hierarchy:: +* No_Task_Termination:: * No_Tasking:: * No_Terminate_Alternatives:: * No_Unchecked_Access:: @@ -7541,6 +7542,11 @@ explicit dependencies on the package @code{Ada.Task_Attributes}. [RM D.7] All (non-environment) tasks depend directly on the environment task of the partition. +@node No_Task_Termination +@unnumberedsubsec No_Task_Termination +@findex No_Task_Termination +[RM D.7] Tasks which terminate are erroneous. + @node No_Tasking @unnumberedsubsec No_Tasking @findex No_Tasking @@ -7605,7 +7611,6 @@ other compilation units in the partition. * No_Obsolescent_Features:: * No_Wide_Characters:: * SPARK:: -* No_Task_Termination:: @end menu @node No_Elaboration_Code @@ -7764,11 +7769,6 @@ This restriction can be useful in providing an initial filter for code developed using SPARK, or in examining legacy code to see how far it is from meeting SPARK restrictions. -@node No_Task_Termination -@unnumberedsubsec No_Task_Termination -@findex No_Task_Termination -[RM D.7] Tasks which terminate are erroneous. - @c ------------------------ @node Implementation Advice @chapter Implementation Advice diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 36691f34d28..56e64c28390 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -772,7 +772,10 @@ package body Ch6 is (N_Expression_Function, Sloc (Specification_Node)); Set_Specification (Body_Node, Specification_Node); Set_Expression (Body_Node, P_Expression); - T_Semicolon; + + -- Expression functions can carry pre/postconditions + + P_Aspect_Specifications (Body_Node); Pop_Scope_Stack; -- Subprogram body case diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index df2ec7a888c..ee45e05473d 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -532,6 +532,15 @@ package body Restrict is elsif not Restrictions.Set (R) then null; + -- Don't complain about No_Obsolescent_Features in an instance, since we + -- will complain on the template, which is much better. Are there other + -- cases like this ??? Do we need a more general mechanism ??? + + elsif R = No_Obsolescent_Features + and then Instantiation_Location (Sloc (N)) /= No_Location + then + null; + -- Here if restriction set, check for violation (either this is a -- Boolean restriction, or a parameter restriction with a value of -- zero and an unknown count, or a parameter restriction with a diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d564b1e590e..9098d538fe0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1818,6 +1818,7 @@ package body Sem_Prag is ("aspect % requires ''Class for null procedure"); elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Expression_Function, N_Generic_Subprogram_Declaration, N_Entry_Declaration) then |