Skip to content

R
riscv-gcc-1
Commit 4b17187f by Arnaud Charlet
Options

[multiple changes] 

2015-05-12  Ed Schonberg  <schonberg@adacore.com>

	* a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type,
	and Reference_Control_Type to support element iterators over
	ordered multisets.
	* a-ciormu.ads, a-ciormu.adb: Ditto for
	indefinite_ordered_multisets.

2015-05-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Expression_With_Actions): Force
	the evaluation of the EWA expression.  Code cleanup.
	(Process_Transient_Object): Code cleanup.
	* exp_util.adb (Is_Aliased): Controlled transient objects found
	within EWA nodes are not aliased.
	(Is_Finalizable_Transient): Iterators are not finalizable transients.

From-SVN: r223076
parent 7858300e
Showing with 263 additions and 29 deletions
gcc/ada/ChangeLog
2015-05-12 Ed Schonberg <schonberg@adacore.com>
* a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type,
and Reference_Control_Type to support element iterators over
ordered multisets.
* a-ciormu.ads, a-ciormu.adb: Ditto for
indefinite_ordered_multisets.
2015-05-12 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_N_Expression_With_Actions): Force
the evaluation of the EWA expression. Code cleanup.
(Process_Transient_Object): Code cleanup.
* exp_util.adb (Is_Aliased): Controlled transient objects found
within EWA nodes are not aliased.
(Is_Finalizable_Transient): Iterators are not finalizable transients.
2015-05-12 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Process_Atomic_Independent_Shared_Volatile):
......
gcc/ada/a-ciormu.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2015, 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- --
......@@ -353,6 +353,45 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
return Node.Color;
end Color;
------------------------
-- Constant_Reference --
------------------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Constant_Reference");
-- Note: in predefined container units, the creation of a reference
-- increments the busy bit of the container, and its finalization
-- decrements it. In the absence of control machinery, this tampering
-- protection is missing.
declare
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
pragma Unreferenced (T);
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element,
Control => (Container => Container'Unrestricted_Access))
do
null;
end return;
end;
end Constant_Reference;
--------------
-- Contains --
--------------
......@@ -1730,6 +1769,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
raise Program_Error with "attempt to stream set cursor";
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Read;
---------------------
-- Replace_Element --
---------------------
......@@ -2055,4 +2102,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
raise Program_Error with "attempt to stream set cursor";
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Write;
end Ada.Containers.Indefinite_Ordered_Multisets;
gcc/ada/a-ciormu.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2015, 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- --
......@@ -52,8 +52,9 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
-- otherwise, it returns True.
type Set is tagged private
with Default_Iterator => Iterate,
Iterator_Element => Element_Type;
with Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
pragma Preelaborable_Initialization (Set);
......@@ -128,6 +129,15 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
-- change the value of the element while Process is executing (to "tamper
-- with elements") will raise Program_Error.
type Constant_Reference_Type
(Element : not null access constant Element_Type) is private
with Implicit_Dereference => Element;
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
function Copy (Source : Set) return Set;
......@@ -469,6 +479,19 @@ private
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
-- In all predefined libraries the following type is controlled, for proper
-- management of tampering checks. For performance reason we omit this
-- machinery for multisets, which are used in a number of our tools.
type Reference_Control_Type is record
Container : Set_Access;
end record;
type Constant_Reference_Type
(Element : not null access constant Element_Type) is record
Control : Reference_Control_Type;
end record;
type Cursor is record
Container : Set_Access;
Node : Node_Access;
......@@ -500,6 +523,18 @@ private
for Set'Read use Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Constant_Reference_Type);
for Constant_Reference_Type'Read use Read;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type);
for Constant_Reference_Type'Write use Write;
Empty_Set : constant Set :=
(Controlled with Tree => (First => null,
Last => null,
......
gcc/ada/a-coormu.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2015, 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- --
......@@ -321,6 +321,45 @@ package body Ada.Containers.Ordered_Multisets is
return Node.Color;
end Color;
------------------------
-- Constant_Reference --
------------------------
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Constant_Reference");
-- Note: in predefined container units, the creation of a reference
-- increments the busy bit of the container, and its finalization
-- decrements it. In the absence of control machinery, this tampering
-- protection is missing.
declare
T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
pragma Unreferenced (T);
begin
return R : constant Constant_Reference_Type :=
(Element => Position.Node.Element'Unrestricted_Access,
Control => (Container => Container'Unrestricted_Access))
do
null;
end return;
end;
end Constant_Reference;
--------------
-- Contains --
--------------
......@@ -1638,6 +1677,14 @@ package body Ada.Containers.Ordered_Multisets is
raise Program_Error with "attempt to stream set cursor";
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Read;
---------------------
-- Replace_Element --
---------------------
......@@ -1937,4 +1984,11 @@ package body Ada.Containers.Ordered_Multisets is
raise Program_Error with "attempt to stream set cursor";
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Write;
end Ada.Containers.Ordered_Multisets;
gcc/ada/a-coormu.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2015, 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- --
......@@ -51,8 +51,9 @@ package Ada.Containers.Ordered_Multisets is
-- otherwise, it returns True.
type Set is tagged private
with Default_Iterator => Iterate,
Iterator_Element => Element_Type;
with Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
pragma Preelaborable_Initialization (Set);
......@@ -127,6 +128,15 @@ package Ada.Containers.Ordered_Multisets is
-- change the value of the element while Process is executing (to "tamper
-- with elements") will raise Program_Error.
type Constant_Reference_Type
(Element : not null access constant Element_Type) is private
with Implicit_Dereference => Element;
function Constant_Reference
(Container : aliased Set;
Position : Cursor) return Constant_Reference_Type;
pragma Inline (Constant_Reference);
procedure Assign (Target : in out Set; Source : Set);
function Copy (Source : Set) return Set;
......@@ -473,6 +483,19 @@ private
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
-- In all predefined libraries the following type is controlled, for proper
-- management of tampering checks. For performance reason we omit this
-- machinery for multisets, which are used in a number of our tools.
type Reference_Control_Type is record
Container : Set_Access;
end record;
type Constant_Reference_Type
(Element : not null access constant Element_Type) is record
Control : Reference_Control_Type;
end record;
type Cursor is record
Container : Set_Access;
Node : Node_Access;
......@@ -504,6 +527,18 @@ private
for Set'Read use Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Constant_Reference_Type);
for Constant_Reference_Type'Read use Read;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type);
for Constant_Reference_Type'Write use Write;
Empty_Set : constant Set :=
(Controlled with Tree => (First => null,
Last => null,
......
gcc/ada/exp_util.adb
......@@ -4713,7 +4713,6 @@ package body Exp_Util is
is
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Desig : Entity_Id := Obj_Typ;
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is initialized either
......@@ -4916,31 +4915,61 @@ package body Exp_Util is
-- Start of processing for Is_Aliased
begin
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr)
and then Nkind (Expr) = N_Reference
and then Nkind (Prefix (Expr)) = N_Identifier
and then Entity (Prefix (Expr)) = Trans_Id
then
return True;
end if;
-- A controlled transient object is not considered aliased when it
-- appears inside an expression_with_actions node even when there are
-- explicit aliases of it:
-- do
-- Trans_Id : Ctrl_Typ ...; -- controlled transient object
-- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends
-- <finalize Trans_Id> -- object safe to finalize
-- in Val end;
-- Expansion ensures that all aliases are encapsulated in the actions
-- list and do not leak to the expression by forcing the evaluation
-- of the expression.
if Nkind (Rel_Node) = N_Expression_With_Actions then
return False;
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Find_Renamed_Object (Stmt);
-- Otherwise examine the statements after the controlled transient
-- object and look for various forms of aliasing.
if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
return True;
else
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
-- Aliasing of the form:
-- Obj : ... := Trans_Id'reference;
if Present (Expr)
and then Nkind (Expr) = N_Reference
and then Nkind (Prefix (Expr)) = N_Identifier
and then Entity (Prefix (Expr)) = Trans_Id
then
return True;
end if;
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Find_Renamed_Object (Stmt);
-- Aliasing of the form:
-- Obj : ... renames ... Trans_Id ...;
if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
return True;
end if;
end if;
end if;
Next (Stmt);
end loop;
Next (Stmt);
end loop;
return False;
return False;
end if;
end Is_Aliased;
------------------
......@@ -5041,6 +5070,10 @@ package body Exp_Util is
return False;
end Is_Iterated_Container;
-- Local variables
Desig : Entity_Id := Obj_Typ;
-- Start of processing for Is_Finalizable_Transient
begin
......@@ -5083,6 +5116,12 @@ package body Exp_Util is
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
-- Do not consider iterators because those are treated as normal
-- controlled objects and are processed by the usual finalization
-- machinery. This avoids the double finalization of an iterator.
and then not Is_Iterator (Desig)
-- Do not consider containers in the context of iterator loops. Such
-- transient objects must exist for as long as the loop is around,
-- otherwise any operation carried out by the iterator will fail.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment