mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 05:20:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

freeze.adb (Check_Expression_Function): At the freeze point of an expression function...

Browse Source 
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.

From-SVN: r213287
This commit is contained in:
Ed Schonberg 2014-07-30 14:34:38 +00:00 committed by Arnaud Charlet
parent 41a58113f8
commit 18c568405a
4 changed files with 175 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -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.

90
gcc/ada/a-ciorse.adb
View File

@ -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;
-----------------------------------

26
gcc/ada/a-ciorse.ads
View File

@ -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;

60
gcc/ada/freeze.adb
View File

@ -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;