Skip to content

R
riscv-gcc-1
Commit f8159014 by Arnaud Charlet
Options

[multiple changes] 

2017-09-06  Raphael Amiard  <amiard@adacore.com>

	* a-chtgop.ads, a-chtgop.adb: Add versions of First and Next with
	Position parameter. If supplied, use it to provide efficient iteration.
	* a-cohase.ads, a-cohase.adb, a-cihama.ads, a-cihama.adb,
	a-cohama.ads, a-cohama.adb: Add/Use Position to provide efficient
	iteration.

2017-09-06  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.adb (Build_Allocate_Deallocate_Proc): If the
	designated type is class-wide and the expression is an unchecked
	conversion, preserve the conversion when checking the tag of the
	designated object, to prevent spurious semantic errors when the
	expression in the conversion has an untagged type (for example
	an address attribute).

From-SVN: r251757
parent e9982c6a
Showing with 147 additions and 54 deletions
gcc/ada/ChangeLog
2017-09-06 Raphael Amiard <amiard@adacore.com>
* a-chtgop.ads, a-chtgop.adb: Add versions of First and Next with
Position parameter. If supplied, use it to provide efficient iteration.
* a-cohase.ads, a-cohase.adb, a-cihama.ads, a-cihama.adb,
a-cohama.ads, a-cohama.adb: Add/Use Position to provide efficient
iteration.
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb (Build_Allocate_Deallocate_Proc): If the
designated type is class-wide and the expression is an unchecked
conversion, preserve the conversion when checking the tag of the
designated object, to prevent spurious semantic errors when the
expression in the conversion has an untagged type (for example
an address attribute).
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Entry_Call): Check whether a protected
......
gcc/ada/a-chtgop.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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- --
......@@ -300,21 +300,30 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
-- First --
-----------
function First (HT : Hash_Table_Type) return Node_Access is
Indx : Hash_Type;
function First
(HT : Hash_Table_Type) return Node_Access
is
Dummy : Hash_Type;
begin
return First (HT, Dummy);
end First;
function First
(HT : Hash_Table_Type;
Position : out Hash_Type) return Node_Access is
begin
if HT.Length = 0 then
Position := Hash_Type'Last;
return null;
end if;
Indx := HT.Buckets'First;
Position := HT.Buckets'First;
loop
if HT.Buckets (Indx) /= null then
return HT.Buckets (Indx);
if HT.Buckets (Position) /= null then
return HT.Buckets (Position);
end if;
Indx := Indx + 1;
Position := Position + 1;
end loop;
end First;
......@@ -590,23 +599,34 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access) return Node_Access
Node : Node_Access;
Position : in out Hash_Type) return Node_Access
is
Result : Node_Access;
First : Hash_Type;
begin
-- First, check if the node has other nodes chained to it
Result := Next (Node);
if Result /= null then
return Result;
end if;
-- Check if we were supplied a position for Node, from which we
-- can start iteration on the buckets.
if Position /= Hash_Type'Last then
First := Position + 1;
else
First := Checked_Index (HT, Node) + 1;
end if;
for Indx in First .. HT.Buckets'Last loop
Result := HT.Buckets (Indx);
if Result /= null then
Position := Indx;
return Result;
end if;
end loop;
......@@ -614,6 +634,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return null;
end Next;
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access) return Node_Access
is
Pos : Hash_Type := Hash_Type'Last;
begin
return Next (HT, Node, Pos);
end Next;
----------------------
-- Reserve_Capacity --
----------------------
......
gcc/ada/a-chtgop.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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- --
......@@ -142,17 +142,31 @@ package Ada.Containers.Hash_Tables.Generic_Operations is
X : Node_Access);
-- Removes node X from the hash table without deallocating the node
function First (HT : Hash_Table_Type) return Node_Access;
function First
(HT : Hash_Table_Type) return Node_Access;
function First
(HT : Hash_Table_Type;
Position : out Hash_Type) return Node_Access;
-- Returns the head of the list in the first (lowest-index) non-empty
-- bucket.
-- bucket. Position will be the index of the bucket of the first node.
-- It is provided so that clients can implement efficient iterators.
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access) return Node_Access;
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access;
Position : in out Hash_Type) return Node_Access;
-- Returns the node that immediately follows Node. This corresponds to
-- either the next node in the same bucket, or (if Node is the last node in
-- its bucket) the head of the list in the first non-empty bucket that
-- follows.
--
-- If Node_Position is supplied, then it will be used as a starting point
-- for iteration (Node_Position must be the index of Node's buckets). If it
-- is not supplied, it will be recomputed. It is provided so that clients
-- can implement efficient iterators.
generic
with procedure Process (Node : Node_Access);
......
gcc/ada/a-cihama.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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- --
......@@ -506,7 +506,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
......@@ -537,12 +537,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-----------
function First (Container : Map) return Cursor is
Node : constant Node_Access := HT_Ops.First (Container.HT);
Pos : Hash_Type;
Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Pos);
end if;
end First;
......@@ -781,7 +782,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unrestricted_Access, Node));
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
......@@ -860,6 +862,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
end Next;
function Next (Position : Cursor) return Cursor is
Node : Node_Access;
Pos : Hash_Type;
begin
if Position.Node = null then
return No_Element;
......@@ -873,16 +877,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
pragma Assert (Vet (Position), "Position cursor of Next is bad");
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
begin
Pos := Position.Position;
Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
if Node = null then
return No_Element;
else
return Cursor'(Position.Container, Node);
return Cursor'(Position.Container, Node, Pos);
end if;
end;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
......
gcc/ada/a-cihama.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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 --
......@@ -354,6 +354,7 @@ private
type Cursor is record
Container : Map_Access;
Node : Node_Access;
Position : Hash_Type := Hash_Type'Last;
end record;
procedure Write
......@@ -433,7 +434,8 @@ private
Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
No_Element : constant Cursor :=
(Container => null, Node => null, Position => Hash_Type'Last);
type Iterator is new Limited_Controlled and
Map_Iterator_Interfaces.Forward_Iterator with
......
gcc/ada/a-cohama.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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- --
......@@ -462,7 +462,7 @@ package body Ada.Containers.Hashed_Maps is
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
......@@ -493,14 +493,14 @@ package body Ada.Containers.Hashed_Maps is
-----------
function First (Container : Map) return Cursor is
Node : constant Node_Access := HT_Ops.First (Container.HT);
Pos : Hash_Type;
Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
begin
if Node = null then
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Pos);
end First;
function First (Object : Iterator) return Cursor is
......@@ -710,7 +710,8 @@ package body Ada.Containers.Hashed_Maps is
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unrestricted_Access, Node));
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
......@@ -779,6 +780,10 @@ package body Ada.Containers.Hashed_Maps is
end Next;
function Next (Position : Cursor) return Cursor is
Node : Node_Access := null;
Pos : Hash_Type;
-- Position of cursor's element in the map buckets.
begin
if Position.Node = null then
return No_Element;
......@@ -786,17 +791,16 @@ package body Ada.Containers.Hashed_Maps is
pragma Assert (Vet (Position), "bad cursor in function Next");
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
-- Initialize to current position, so that HT_Ops.Next can use it
Pos := Position.Position;
Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
begin
if Node = null then
return No_Element;
else
return Cursor'(Position.Container, Node, Pos);
end if;
return Cursor'(Position.Container, Node);
end;
end Next;
procedure Next (Position : in out Cursor) is
......
gcc/ada/a-cohama.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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 --
......@@ -359,7 +359,14 @@ private
type Cursor is record
Container : Map_Access;
-- Access to this cursor's container
Node : Node_Access;
-- Access to the node pointed to by this cursor
Position : Hash_Type := Hash_Type'Last;
-- Position of the node in the buckets of the container. If this is
-- equal to Hash_Type'Last, then it will not be used.
end record;
procedure Read
......@@ -442,7 +449,8 @@ private
Empty_Map : constant Map := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
No_Element : constant Cursor := (Container => null, Node => null,
Position => Hash_Type'Last);
type Iterator is new Limited_Controlled and
Map_Iterator_Interfaces.Forward_Iterator with
......
gcc/ada/a-cohase.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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- --
......@@ -595,7 +595,7 @@ package body Ada.Containers.Hashed_Sets is
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
......@@ -657,14 +657,14 @@ package body Ada.Containers.Hashed_Sets is
-----------
function First (Container : Set) return Cursor is
Node : constant Node_Access := HT_Ops.First (Container.HT);
Pos : Hash_Type;
Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
begin
if Node = null then
return No_Element;
end if;
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'(Container'Unrestricted_Access, Node, Pos);
end First;
function First (Object : Iterator) return Cursor is
......@@ -989,7 +989,8 @@ package body Ada.Containers.Hashed_Sets is
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unrestricted_Access, Node));
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
......@@ -1038,6 +1039,8 @@ package body Ada.Containers.Hashed_Sets is
end Next;
function Next (Position : Cursor) return Cursor is
Node : Node_Access;
Pos : Hash_Type;
begin
if Position.Node = null then
return No_Element;
......@@ -1045,17 +1048,14 @@ package body Ada.Containers.Hashed_Sets is
pragma Assert (Vet (Position), "bad cursor in Next");
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
Pos := Position.Position;
Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
begin
if Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Node);
end;
return Cursor'(Position.Container, Node, Pos);
end Next;
procedure Next (Position : in out Cursor) is
......@@ -1957,7 +1957,8 @@ package body Ada.Containers.Hashed_Sets is
if Node = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Node);
return Cursor'
(Container'Unrestricted_Access, Node, Hash_Type'Last);
end if;
end Find;
......
gcc/ada/a-cohase.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2017, 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 --
......@@ -528,6 +528,7 @@ private
type Cursor is record
Container : Set_Access;
Node : Node_Access;
Position : Hash_Type := Hash_Type'Last;
end record;
procedure Write
......@@ -588,7 +589,8 @@ private
Empty_Set : constant Set := (Controlled with others => <>);
No_Element : constant Cursor := (Container => null, Node => null);
No_Element : constant Cursor :=
(Container => null, Node => null, Position => Hash_Type'Last);
type Iterator is new Limited_Controlled and
Set_Iterator_Interfaces.Forward_Iterator with
......
gcc/ada/exp_util.adb
......@@ -871,12 +871,26 @@ package body Exp_Util is
-- Temp'Tag
-- If the object is an unchecked conversion (typically to
-- an access to class-wide type), we must preserve the
-- conversion to ensure that the object is seen as tagged
-- in the code that follows.
else
if
Nkind (Parent (Temp)) = N_Unchecked_Type_Conversion
then
Param :=
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Parent (Temp)),
Attribute_Name => Name_Tag);
else
Param :=
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Temp),
Attribute_Name => Name_Tag);
end if;
end if;
-- Generate:
-- Needs_Finalization (<Param>)
......
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