[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.
This commit is contained in:
Steve Baird
Pierre-Marie de Rodat
parent
2528d0c7ce
commit
3598c8db40
@ -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) \
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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);
|
||||
|
||||
Unsorted : constant List_Descriptor :=
|
||||
(First => Container.First,
|
||||
Last => Container.Last,
|
||||
Length => Container.Length);
|
||||
package Descriptors is new List_Descriptors
|
||||
(Node_Ref => Node_Access, Nil => null);
|
||||
use Descriptors;
|
||||
|
||||
Sorted : List_Descriptor;
|
||||
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;
|
||||
|
||||
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
|
||||
-- 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);
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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);
|
||||
|
||||
191
gcc/ada/libgnat/a-costso.adb
Normal file
191
gcc/ada/libgnat/a-costso.adb
Normal file
@ -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;
|
||||
71
gcc/ada/libgnat/a-costso.ads
Normal file
71
gcc/ada/libgnat/a-costso.ads
Normal file
@ -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;
|
||||
@ -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);
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user