+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.
-- --
-- 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- --
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 --
-------------
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 --
----------
(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
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;
-----------------------------------
-- --
-- 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 --
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;
-- 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
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 --
----------------------------
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;
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;
projects / gcc.git / commitdiff