From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 068373857C59; Tue, 21 Sep 2021 15:26:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 068373857C59 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-3732] [Ada] Refactor sort procedures of doubly linked list containers X-Act-Checkin: gcc X-Git-Author: Steve Baird X-Git-Refname: refs/heads/master X-Git-Oldrev: 2528d0c7ce0536b3299f6a7452195362002c1a8c X-Git-Newrev: 3598c8db4045d17705f845561517f74bf877a2e4 Message-Id: <20210921152614.068373857C59@sourceware.org> Date: Tue, 21 Sep 2021 15:26:14 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Tue, 21 Sep 2021 15:26:14 -0000 https://gcc.gnu.org/g:3598c8db4045d17705f845561517f74bf877a2e4 commit r12-3732-g3598c8db4045d17705f845561517f74bf877a2e4 Author: Steve Baird Date: Wed Jun 30 16:42:54 2021 -0700 [Ada] Refactor sort procedures of doubly linked list containers gcc/ada/ * libgnat/a-costso.ads, libgnat/a-costso.adb: A new library unit, Ada.Containers.Stable_Sorting, which exports a pair of generics (one within the other) which are instantiated by each of the 5 doubly-linked list container generics to implement their respective Sort procedures. We use a pair of generics, rather than a single generic, in order to further reduce code duplication. The outer generic takes a formal private Node_Ref type representing a reference to a linked list element. For some instances, the corresponding actual parameter will be an access type; for others, it will be the index type for an array. * Makefile.rtl: Include new Ada.Containers.Stable_Sorting unit. * libgnat/a-cbdlli.adb, libgnat/a-cdlili.adb, libgnat/a-cfdlli.adb, libgnat/a-cidlli.adb, libgnat/a-crdlli.adb (Sort): Replace existing Sort implementation with a call to an instance of Ada.Containers.Stable_Sorting.Doubly_Linked_List_Sort. Declare the (trivial) actual parameters needed to declare that instance. * libgnat/a-cfdlli.ads: Fix a bug encountered during testing in the postcondition for M_Elements_Sorted. With a partial ordering, it is possible for all three of (X < Y), (Y < X), and (X = Y) to be simultaneously false, so that case needs to handled correctly. Diff: --- gcc/ada/Makefile.rtl | 1 + gcc/ada/libgnat/a-cbdlli.adb | 107 ++++++++-------------- gcc/ada/libgnat/a-cdlili.adb | 205 ++++++++----------------------------------- gcc/ada/libgnat/a-cfdlli.adb | 112 +++++++++-------------- gcc/ada/libgnat/a-cfdlli.ads | 3 +- gcc/ada/libgnat/a-cidlli.adb | 105 ++++++++-------------- gcc/ada/libgnat/a-costso.adb | 191 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/libgnat/a-costso.ads | 71 +++++++++++++++ gcc/ada/libgnat/a-crdlli.adb | 108 +++++++++-------------- 9 files changed, 455 insertions(+), 448 deletions(-) diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index fb851a6bd92..f32ed170ef2 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -162,6 +162,7 @@ GNATRTL_NONTASKING_OBJS= \ a-coormu$(objext) \ a-coorse$(objext) \ a-coprnu$(objext) \ + a-costso$(objext) \ a-coteio$(objext) \ a-crbltr$(objext) \ a-crbtgk$(objext) \ diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index 143805ef2b6..3752ca94aff 100644 --- a/gcc/ada/libgnat/a-cbdlli.adb +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -858,74 +860,6 @@ is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - -- What does this do ??? - - procedure Sort (Front, Back : Count_Type); - -- Internal procedure, what does it do??? rename it??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -941,8 +875,43 @@ is declare Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; begin - Sort (Front => 0, Back => 0); + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (N (Container.First).Prev = 0); diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb index d9897511306..1d48ed9209a 100644 --- a/gcc/ada/libgnat/a-cdlili.adb +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -674,156 +676,6 @@ is ---------- procedure Sort (Container : in out List) is - - type List_Descriptor is - record - First, Last : Node_Access; - Length : Count_Type; - end record; - - function Merge_Sort (Arg : List_Descriptor) return List_Descriptor; - -- Sort list of given length using MergeSort; length must be >= 2. - -- As required by RM, the sort is stable. - - ---------------- - -- Merge_Sort -- - ---------------- - - function Merge_Sort (Arg : List_Descriptor) return List_Descriptor - is - procedure Split_List - (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor); - -- Split list into two parts for divide-and-conquer. - -- Unsplit.Length must be >= 2. - - function Merge_Parts - (Part1, Part2 : List_Descriptor) return List_Descriptor; - -- Merge two sorted lists, preserving sorted property. - - ---------------- - -- Split_List -- - ---------------- - - procedure Split_List - (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor) - is - Rover : Node_Access := Unsplit.First; - Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2; - begin - for Iter in 1 .. Bump_Count loop - Rover := Rover.Next; - end loop; - - Part1 := (First => Unsplit.First, - Last => Rover, - Length => Bump_Count + 1); - - Part2 := (First => Rover.Next, - Last => Unsplit.Last, - Length => Unsplit.Length - Part1.Length); - - -- Detach - Part1.Last.Next := null; - Part2.First.Prev := null; - end Split_List; - - ----------------- - -- Merge_Parts -- - ----------------- - - function Merge_Parts - (Part1, Part2 : List_Descriptor) return List_Descriptor - is - Empty : constant List_Descriptor := (null, null, 0); - - procedure Detach_First (Source : in out List_Descriptor; - Detached : out Node_Access); - -- Detach the first element from a non-empty list and - -- return the detached node via the Detached parameter. - - ------------------ - -- Detach_First -- - ------------------ - - procedure Detach_First (Source : in out List_Descriptor; - Detached : out Node_Access) is - begin - Detached := Source.First; - - if Source.Length = 1 then - Source := Empty; - else - Source := (Source.First.Next, - Source.Last, - Source.Length - 1); - - Detached.Next.Prev := null; - Detached.Next := null; - end if; - end Detach_First; - - P1 : List_Descriptor := Part1; - P2 : List_Descriptor := Part2; - Merged : List_Descriptor := Empty; - - Take_From_P2 : Boolean; - Detached : Node_Access; - - -- Start of processing for Merge_Parts - - begin - while (P1.Length /= 0) or (P2.Length /= 0) loop - if P1.Length = 0 then - Take_From_P2 := True; - elsif P2.Length = 0 then - Take_From_P2 := False; - else - -- If the compared elements are equal then Take_From_P2 - -- must be False in order to ensure stability. - - Take_From_P2 := P2.First.Element < P1.First.Element; - end if; - - if Take_From_P2 then - Detach_First (P2, Detached); - else - Detach_First (P1, Detached); - end if; - - if Merged.Length = 0 then - Merged := (First | Last => Detached, Length => 1); - else - Detached.Prev := Merged.Last; - Merged.Last.Next := Detached; - Merged.Last := Detached; - Merged.Length := Merged.Length + 1; - end if; - end loop; - return Merged; - end Merge_Parts; - - -- Start of processing for Merge_Sort - - begin - if Arg.Length < 2 then - -- already sorted - return Arg; - end if; - - declare - Part1, Part2 : List_Descriptor; - begin - Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2); - - Part1 := Merge_Sort (Part1); - Part2 := Merge_Sort (Part2); - - return Merge_Parts (Part1, Part2); - end; - end Merge_Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -838,28 +690,43 @@ is -- element tampering by a generic actual subprogram. declare - Lock : With_Lock (Container.TC'Unchecked_Access); + Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Node_Access, Nil => null); + use Descriptors; + + function Next (N : Node_Access) return Node_Access is (N.Next); + procedure Set_Next (N : Node_Access; Next : Node_Access) + with Inline; + procedure Set_Prev (N : Node_Access; Prev : Node_Access) + with Inline; + function "<" (L, R : Node_Access) return Boolean is + (L.Element < R.Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (N : Node_Access; Next : Node_Access) is + begin + N.Next := Next; + end Set_Next; - Unsorted : constant List_Descriptor := - (First => Container.First, - Last => Container.Last, - Length => Container.Length); + procedure Set_Prev (N : Node_Access; Prev : Node_Access) is + begin + N.Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; - Sorted : List_Descriptor; + procedure Sort_List is new Doubly_Linked_List_Sort; begin - -- If a call to the formal < operator references the container - -- during sorting, seeing an empty container seems preferable - -- to seeing an internally inconsistent container. - -- - Container.First := null; - Container.Last := null; - Container.Length := 0; - - Sorted := Merge_Sort (Unsorted); - - Container.First := Sorted.First; - Container.Last := Sorted.Last; - Container.Length := Sorted.Length; + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (Container.First.Prev = null); diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb index b289def23fa..c9897c76177 100644 --- a/gcc/ada/libgnat/a-cfdlli.adb +++ b/gcc/ada/libgnat/a-cfdlli.adb @@ -25,6 +25,8 @@ -- . -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; package body Ada.Containers.Formal_Doubly_Linked_Lists with @@ -976,77 +978,6 @@ is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot : Count_Type; Back : Count_Type); - procedure Sort (Front : Count_Type; Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Count_Type; Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front : Count_Type; Back : Count_Type) is - Pivot : Count_Type; - - begin - if Front = 0 then - Pivot := Container.First; - else - Pivot := N (Front).Next; - end if; - - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -1055,7 +986,44 @@ is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - Sort (Front => 0, Back => 0); + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 8713d33bf34..590643e7af0 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -1596,8 +1596,7 @@ is M_Elements_Sorted'Result = (for all I in 1 .. M.Length (Container) => (for all J in I .. M.Length (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); + not (Element (Container, J) < Element (Container, I)))); pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); end Formal_Model; diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 3fc57da552e..1cf94013c54 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; with System.Put_Images; @@ -731,73 +733,6 @@ is ---------- procedure Sort (Container : in out List) is - procedure Partition (Pivot : Node_Access; Back : Node_Access); - -- Comment ??? - - procedure Sort (Front, Back : Node_Access); - -- Comment??? Confusing name??? change name??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access; - - begin - Node := Pivot.Next; - while Node /= Back loop - if Node.Element.all < Pivot.Element.all then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; - - begin - Prev.Next := Next; - - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; - - Node.Next := Pivot; - Node.Prev := Pivot.Prev; - - Pivot.Prev := Node; - - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; - - Node := Next; - end; - - else - Node := Node.Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Node_Access) is - Pivot : constant Node_Access := - (if Front = null then Container.First else Front.Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; @@ -813,8 +748,42 @@ is declare Lock : With_Lock (Container.TC'Unchecked_Access); + + package Descriptors is new List_Descriptors + (Node_Ref => Node_Access, Nil => null); + use Descriptors; + + function Next (N : Node_Access) return Node_Access is (N.Next); + procedure Set_Next (N : Node_Access; Next : Node_Access) + with Inline; + procedure Set_Prev (N : Node_Access; Prev : Node_Access) + with Inline; + function "<" (L, R : Node_Access) return Boolean is + (L.Element.all < R.Element.all); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (N : Node_Access; Next : Node_Access) is + begin + N.Next := Next; + end Set_Next; + + procedure Set_Prev (N : Node_Access; Prev : Node_Access) is + begin + N.Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; begin - Sort (Front => null, Back => null); + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); end; pragma Assert (Container.First.Prev = null); diff --git a/gcc/ada/libgnat/a-costso.adb b/gcc/ada/libgnat/a-costso.adb new file mode 100644 index 00000000000..e14ecbbae4d --- /dev/null +++ b/gcc/ada/libgnat/a-costso.adb @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . S T A B L E _ S O R T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2021, AdaCore -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Stable_Sorting is + package body List_Descriptors is + procedure Doubly_Linked_List_Sort (List : List_Descriptor) is + + Empty : constant List_Descriptor := (Nil, Nil, 0); + + function Merge_Sort (Arg : List_Descriptor) return List_Descriptor; + -- Sort list of given length using MergeSort; length must be >= 2. + -- As required by RM, the sort is stable. + + ---------------- + -- Merge_Sort -- + ---------------- + + function Merge_Sort (Arg : List_Descriptor) return List_Descriptor + is + procedure Split_List + (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor); + -- Split list into two parts for divide-and-conquer. + -- Unsplit.Length must be >= 2. + + function Merge_Parts + (Part1, Part2 : List_Descriptor) return List_Descriptor; + -- Merge two sorted lists, preserving sorted property. + + ---------------- + -- Split_List -- + ---------------- + + procedure Split_List + (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor) + is + Rover : Node_Ref := Unsplit.First; + Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2; + begin + for Iter in 1 .. Bump_Count loop + Rover := Next (Rover); + end loop; + + Part1 := (First => Unsplit.First, + Last => Rover, + Length => Bump_Count + 1); + + Part2 := (First => Next (Rover), + Last => Unsplit.Last, + Length => Unsplit.Length - Part1.Length); + + -- Detach + Set_Next (Part1.Last, Nil); + Set_Prev (Part2.First, Nil); + end Split_List; + + ----------------- + -- Merge_Parts -- + ----------------- + + function Merge_Parts + (Part1, Part2 : List_Descriptor) return List_Descriptor + is + procedure Detach_First (Source : in out List_Descriptor; + Detached : out Node_Ref); + -- Detach the first element from a non-empty list and + -- return the detached node via the Detached parameter. + + ------------------ + -- Detach_First -- + ------------------ + + procedure Detach_First (Source : in out List_Descriptor; + Detached : out Node_Ref) is + begin + Detached := Source.First; + + if Source.Length = 1 then + Source := Empty; + else + Source := (Next (Source.First), + Source.Last, + Source.Length - 1); + + Set_Prev (Next (Detached), Nil); + Set_Next (Detached, Nil); + end if; + end Detach_First; + + P1 : List_Descriptor := Part1; + P2 : List_Descriptor := Part2; + Merged : List_Descriptor := Empty; + + Take_From_P2 : Boolean; + Detached : Node_Ref; + + -- Start of processing for Merge_Parts + + begin + while (P1.Length /= 0) or (P2.Length /= 0) loop + if P1.Length = 0 then + Take_From_P2 := True; + elsif P2.Length = 0 then + Take_From_P2 := False; + else + -- If the compared elements are equal then Take_From_P2 + -- must be False in order to ensure stability. + + Take_From_P2 := P2.First < P1.First; + end if; + + if Take_From_P2 then + Detach_First (P2, Detached); + else + Detach_First (P1, Detached); + end if; + + if Merged.Length = 0 then + Merged := (First | Last => Detached, Length => 1); + else + Set_Prev (Detached, Merged.Last); + Set_Next (Merged.Last, Detached); + Merged.Last := Detached; + Merged.Length := Merged.Length + 1; + end if; + end loop; + return Merged; + end Merge_Parts; + + -- Start of processing for Merge_Sort + + begin + if Positive (Arg.Length) < 2 then + -- already sorted + return Arg; + end if; + + declare + Part1, Part2 : List_Descriptor; + begin + Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2); + + Part1 := Merge_Sort (Part1); + Part2 := Merge_Sort (Part2); + + return Merge_Parts (Part1, Part2); + end; + end Merge_Sort; + + -- Start of processing for Sort + + begin + if List.Length > 1 then + -- If a call to the formal "<" op references the container + -- during sorting, seeing an empty container seems preferable + -- to seeing an internally inconsistent container. + -- + Update_Container (Empty); + + Update_Container (Merge_Sort (List)); + end if; + end Doubly_Linked_List_Sort; + end List_Descriptors; +end Ada.Containers.Stable_Sorting; diff --git a/gcc/ada/libgnat/a-costso.ads b/gcc/ada/libgnat/a-costso.ads new file mode 100644 index 00000000000..db0be24c5e3 --- /dev/null +++ b/gcc/ada/libgnat/a-costso.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . S T A B L E _ S O R T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2021, AdaCore -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Stable_Sorting package + +-- This package provides a generic stable sorting procedure that is +-- intended for use by the various doubly linked list container generics. +-- If a stable array sorting algorithm with better-than-quadratic worst +-- case execution time is ever needed, then it could also reside here. + +private package Ada.Containers.Stable_Sorting is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + -- Stable sorting algorithms with N-log-N worst case execution time. + + generic + type Node_Ref is private; -- access value or array index + Nil : Node_Ref; + package List_Descriptors is + + type List_Descriptor is + record + First, Last : Node_Ref := Nil; + Length : Count_Type := 0; + end record; + + -- We use a nested generic here so that the inner generic can + -- refer to the List_Descriptor type. + + generic + with function Next (N : Node_Ref) return Node_Ref is <>; + with procedure Set_Next (N : Node_Ref; Next : Node_Ref) is <>; + with procedure Set_Prev (N : Node_Ref; Prev : Node_Ref) is <>; + with function "<" (L, R : Node_Ref) return Boolean is <>; + + with procedure Update_Container (List : List_Descriptor) is <>; + procedure Doubly_Linked_List_Sort (List : List_Descriptor); + + end List_Descriptors; + +end Ada.Containers.Stable_Sorting; diff --git a/gcc/ada/libgnat/a-crdlli.adb b/gcc/ada/libgnat/a-crdlli.adb index 6538b26ce22..48cdb0c4c2c 100644 --- a/gcc/ada/libgnat/a-crdlli.adb +++ b/gcc/ada/libgnat/a-crdlli.adb @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + with System; use type System.Address; package body Ada.Containers.Restricted_Doubly_Linked_Lists is @@ -509,83 +511,53 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is procedure Sort (Container : in out List) is N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - procedure Sort (Front, Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type := N (Pivot).Next; - - begin - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - begin if Container.Length <= 1 then return; end if; - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - -- if Container.Busy > 0 then -- raise Program_Error; -- end if; - Sort (Front => 0, Back => 0); + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element < N (R).Element); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0);