From f8159014019f2aa3b3e53970732d087dd93fc432 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 11:27:45 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Raphael Amiard * 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 * 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 --- gcc/ada/ChangeLog | 17 +++++++++++++++ gcc/ada/a-chtgop.adb | 49 +++++++++++++++++++++++++++++++++++--------- gcc/ada/a-chtgop.ads | 20 +++++++++++++++--- gcc/ada/a-cihama.adb | 32 +++++++++++++++-------------- gcc/ada/a-cihama.ads | 6 ++++-- gcc/ada/a-cohama.adb | 34 ++++++++++++++++-------------- gcc/ada/a-cohama.ads | 12 +++++++++-- gcc/ada/a-cohase.adb | 33 ++++++++++++++--------------- gcc/ada/a-cohase.ads | 6 ++++-- gcc/ada/exp_util.adb | 22 ++++++++++++++++---- 10 files changed, 162 insertions(+), 69 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f6f19dc3b90..268eb13cf8c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2017-09-06 Raphael Amiard + + * 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 + + * 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 * sem_res.adb (Resolve_Entry_Call): Check whether a protected diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 53b564f9762..2b85b29e9d5 100644 --- a/gcc/ada/a-chtgop.adb +++ b/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; @@ -589,24 +598,35 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ---------- 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; @@ -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 -- ---------------------- diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index 1b865dcbd29..ba68b2dd772 100644 --- a/gcc/ada/a-chtgop.ads +++ b/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); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 3c05aac5b49..0d843795ab8 100644 --- a/gcc/ada/a-cihama.adb +++ b/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 - 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 diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 5ad65886c14..dad34756cac 100644 --- a/gcc/ada/a-cihama.ads +++ b/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 diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 20a48b6d6c2..d4a0d591ce9 100644 --- a/gcc/ada/a-cohama.adb +++ b/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; - 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 diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 7443b545e86..8a6f8c2ca8c 100644 --- a/gcc/ada/a-cohama.ads +++ b/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 diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 5f31e58f38f..eab8a4056fe 100644 --- a/gcc/ada/a-cohase.adb +++ b/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; + 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; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 681087a2913..79e34007428 100644 --- a/gcc/ada/a-cohase.ads +++ b/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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8270ea5499c..8098a93af6b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -871,11 +871,25 @@ 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 - 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: -- 2.30.2