diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 90 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 60 |
4 files changed, 175 insertions, 14 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fea05ae35f1..df58f1af553 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2014-07-30 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Check_Expression_Function): At the freeze point + of an expression function, verify that the expression in the + function does not contain references to any deferred constants + that have no completion yet. + (Freeze_Expression, Freeze_Before): call + Check_Expression_Function. + * a-ciorse.ads: Add Reference_Control_Type to detect tampering. + * a-ciorse.adb: Add Adjust and Finalize routines for + Reference_Control_Type. Use it in the construction of Reference + and Constant_Reference values. + 2014-07-30 Robert Dewar <dewar@adacore.com> * exp_aggr.adb: Update comments. diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index b79d27e8b15..7c14cac72cb 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.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- -- @@ -768,6 +768,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------- -- Ceiling -- ------------- @@ -878,6 +896,32 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if not (Key (Control.Pos) = Control.Old_Key.all) then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + Control.Old_Key := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1004,11 +1048,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Vet (Container.Tree, Position.Node), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - - return (Element => Position.Node.Element.all'Access); + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; function Reference_Preserving_Key @@ -1026,11 +1082,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "Node has no element"; end if; - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Key has not - -- changed. ??? - - return (Element => Node.Element.all'Access); + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; ----------------------------------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index 0dba13e42ed..830f9886624 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.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 -- @@ -293,8 +293,28 @@ package Ada.Containers.Indefinite_Ordered_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type - (Element : not null access Element_Type) is null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_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 Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f44cfb16aae..abc84cc4fe0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -105,6 +105,12 @@ package body Freeze is -- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order -- attribute definition clause. + procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id); + -- When an expression function is frozen by a use of it, the expression + -- itself is frozen. Check that the expression does not include references + -- to deferred constants without completion. We report this at the + -- freeze point of the function, to provide a better error message. + procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased -- or tagged or contains something this is aliased or tagged, set @@ -1233,6 +1239,50 @@ package body Freeze is end if; end Check_Debug_Info_Needed; + ------------------------------- + -- Check_Expression_Function -- + ------------------------------- + + procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is + Decl : Node_Id; + + function Find_Constant (Nod : Node_Id) return Traverse_Result; + -- Function to search for deferred constant + + ------------------- + -- Find_Constant -- + ------------------- + + function Find_Constant (Nod : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (Nod) + and then Present (Entity (Nod)) + and then Ekind (Entity (Nod)) = E_Constant + and then not Is_Imported (Entity (Nod)) + and then not Has_Completion (Entity (Nod)) + and then Scope (Entity (Nod)) = Current_Scope + then + Error_Msg_NE + ("premature use of& in call or instance", N, Entity (Nod)); + end if; + + return OK; + end Find_Constant; + + procedure Check_Deferred is new Traverse_Proc (Find_Constant); + + -- Start of processing for Check_Expression_Function + + begin + Decl := Original_Node (Unit_Declaration_Node (Nam)); + + if Scope (Nam) = Current_Scope + and then Nkind (Decl) = N_Expression_Function + then + Check_Deferred (Expression (Decl)); + end if; + end Check_Expression_Function; + ---------------------------- -- Check_Strict_Alignment -- ---------------------------- @@ -1741,7 +1791,12 @@ package body Freeze is procedure Freeze_Before (N : Node_Id; T : Entity_Id) is Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); + begin + if Ekind (T) = E_Function then + Check_Expression_Function (N, T); + end if; + if Is_Non_Empty_List (Freeze_Nodes) then Insert_Actions (N, Freeze_Nodes); end if; @@ -5787,6 +5842,11 @@ package body Freeze is or else not Comes_From_Source (Entity (N))) then Nam := Entity (N); + + if Present (Nam) and then Ekind (Nam) = E_Function then + Check_Expression_Function (N, Nam); + end if; + else Nam := Empty; end if; |