+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
-- --
-- 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- --
-- 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;
----------
function Next
- (HT : aliased in out Hash_Table_Type;
- Node : Node_Access) return Node_Access
+ (HT : aliased in out Hash_Table_Type;
+ 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;
- First := Checked_Index (HT, Node) + 1;
+ -- 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;
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 --
----------------------
-- --
-- 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- --
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);
-- --
-- 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- --
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
-----------
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;
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);
end Next;
function Next (Position : Cursor) return Cursor is
+ Node : Node_Access;
+ Pos : Hash_Type;
begin
if Position.Node = null then
return No_Element;
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
- if Node = null then
- return No_Element;
- else
- return Cursor'(Position.Container, Node);
- end if;
- end;
+ 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, Pos);
+ end if;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
-- --
-- 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 --
type Cursor is record
Container : Map_Access;
Node : Node_Access;
+ Position : Hash_Type := Hash_Type'Last;
end record;
procedure Write
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
-- --
-- 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- --
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
-----------
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
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);
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;
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;
- begin
- if Node = null then
- return No_Element;
- end if;
+ Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
- return Cursor'(Position.Container, Node);
- end;
+ if Node = null then
+ return No_Element;
+ else
+ return Cursor'(Position.Container, Node, Pos);
+ end if;
end Next;
procedure Next (Position : in out Cursor) is
-- --
-- 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 --
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
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
-- --
-- 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- --
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
end Find;
--------------------
-----------
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
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);
end Next;
function Next (Position : Cursor) return Cursor is
+ Node : Node_Access;
+ Pos : Hash_Type;
begin
if Position.Node = null then
return No_Element;
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;
+ 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
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;
-- --
-- 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 --
type Cursor is record
Container : Set_Access;
Node : Node_Access;
+ Position : Hash_Type := Hash_Type'Last;
end record;
procedure Write
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
-- 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
- Param :=
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Temp),
- Attribute_Name => Name_Tag);
+ 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:
projects / gcc.git / commitdiff