public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-3732] [Ada] Refactor sort procedures of doubly linked list containers
@ 2021-09-21 15:26 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-09-21 15:26 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:3598c8db4045d17705f845561517f74bf877a2e4
commit r12-3732-g3598c8db4045d17705f845561517f74bf877a2e4
Author: Steve Baird <baird@adacore.com>
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 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
+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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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);
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-09-21 15:26 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-09-21 15:26 [gcc r12-3732] [Ada] Refactor sort procedures of doubly linked list containers Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).