Skip to content

R
riscv-gcc-1
Commit 392f673a by Matthew Heaney Committed by Arnaud Charlet
Options

a-cgcaso.adb, [...]: Implemented using heapsort instead of quicksort. 

2006-02-13  Matthew Heaney  <heaney@adacore.com>

	* a-cgcaso.adb, a-cgaaso.adb: Implemented using heapsort instead of
	quicksort.

From-SVN: r111036
parent ffabcde5
Showing with 145 additions and 163 deletions
gcc/ada/a-cgaaso.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -34,93 +34,103 @@ ...@@ -34,93 +34,103 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]).
with System;
procedure Ada.Containers.Generic_Anonymous_Array_Sort procedure Ada.Containers.Generic_Anonymous_Array_Sort
(First, Last : Index_Type'Base) (First, Last : Index_Type'Base)
is is
Pivot, Lo, Mid, Hi : Index_Type; type T is range System.Min_Int .. System.Max_Int;
begin function To_Index (J : T) return Index_Type;
if Last <= First then pragma Inline (To_Index);
return;
end if;
Lo := First;
Hi := Last;
if Last = Index_Type'Succ (First) then
if not Less (Lo, Hi) then
Swap (Lo, Hi);
end if;
return;
end if;
Mid := Index_Type'Val
(Index_Type'Pos (Lo) +
(Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2);
-- We need to figure out which case we have:
-- x < y < z
-- x < z < y
-- z < x < y
-- y < x < z
-- y < z < x
-- z < y < x
if Less (Lo, Mid) then
if Less (Lo, Hi) then
if Less (Mid, Hi) then
Swap (Lo, Mid);
else function Lt (J, K : T) return Boolean;
Swap (Lo, Hi); pragma Inline (Lt);
end if; procedure Xchg (J, K : T);
pragma Inline (Xchg);
procedure Sift (S : T);
--------------
-- To_Index --
--------------
function To_Index (J : T) return Index_Type is
K : constant T'Base := Index_Type'Pos (First) + J - T'(1);
begin
return Index_Type'Val (K);
end To_Index;
else --------
null; -- lo is median -- Lt --
end if; --------
elsif Less (Lo, Hi) then function Lt (J, K : T) return Boolean is
null; -- lo is median begin
return Less (To_Index (J), To_Index (K));
end Lt;
elsif Less (Mid, Hi) then ----------
Swap (Lo, Hi); -- Xchg --
----------
else procedure Xchg (J, K : T) is
Swap (Lo, Mid); begin
end if; Swap (To_Index (J), To_Index (K));
end Xchg;
Pivot := Lo; Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1);
Outer : loop
----------
-- Sift --
----------
procedure Sift (S : T) is
C : T := S;
Son : T;
Father : T;
begin
loop loop
exit Outer when not (Pivot < Hi); Son := C + C;
if Less (Hi, Pivot) then if Son < Max then
Swap (Hi, Pivot); if Lt (Son, Son + 1) then
Pivot := Hi; Son := Son + 1;
Lo := Index_Type'Succ (Lo); end if;
elsif Son > Max then
exit; exit;
else
Hi := Index_Type'Pred (Hi);
end if; end if;
Xchg (Son, C);
C := Son;
end loop; end loop;
loop while C /= S loop
exit Outer when not (Lo < Pivot); Father := C / 2;
if Less (Lo, Pivot) then if Lt (Father, C) then
Lo := Index_Type'Succ (Lo); Xchg (Father, C);
C := Father;
else else
Swap (Lo, Pivot);
Pivot := Lo;
Hi := Index_Type'Pred (Hi);
exit; exit;
end if; end if;
end loop; end loop;
end loop Outer; end Sift;
Generic_Anonymous_Array_Sort (First, Index_Type'Pred (Pivot)); -- Start of processing for Generic_Anonymous_Array_Sort
Generic_Anonymous_Array_Sort (Index_Type'Succ (Pivot), Last);
begin
for J in reverse 1 .. Max / 2 loop
Sift (J);
end loop;
while Max > 1 loop
Xchg (1, Max);
Max := Max - 1;
Sift (1);
end loop;
end Ada.Containers.Generic_Anonymous_Array_Sort; end Ada.Containers.Generic_Anonymous_Array_Sort;
gcc/ada/a-cgcaso.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -34,130 +34,102 @@ ...@@ -34,130 +34,102 @@
-- This unit has originally being developed by Matthew J Heaney. -- -- This unit has originally being developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]).
with System;
procedure Ada.Containers.Generic_Constrained_Array_Sort procedure Ada.Containers.Generic_Constrained_Array_Sort
(Container : in out Array_Type) (Container : in out Array_Type)
is is
function Is_Less (I, J : Index_Type) return Boolean; type T is range System.Min_Int .. System.Max_Int;
pragma Inline (Is_Less);
procedure Swap (I, J : Index_Type); function To_Index (J : T) return Index_Type;
pragma Inline (Swap); pragma Inline (To_Index);
procedure Sort (First, Last : Index_Type'Base); procedure Sift (S : T);
------------- A : Array_Type renames Container;
-- Is_Less --
-------------
function Is_Less (I, J : Index_Type) return Boolean is --------------
-- To_Index --
--------------
function To_Index (J : T) return Index_Type is
K : constant T'Base := Index_Type'Pos (A'First) + J - T'(1);
begin begin
return Container (I) < Container (J); return Index_Type'Val (K);
end Is_Less; end To_Index;
Max : T := A'Length;
Temp : Element_Type;
---------- ----------
-- Sort -- -- Sift --
---------- ----------
procedure Sort (First, Last : Index_Type'Base) is procedure Sift (S : T) is
Pivot, Lo, Mid, Hi : Index_Type; C : T := S;
Son : T;
begin begin
if Last <= First then loop
return; Son := 2 * C;
end if;
Lo := First;
Hi := Last;
if Last = Index_Type'Succ (First) then
if not Is_Less (Lo, Hi) then
Swap (Lo, Hi);
end if;
return;
end if;
Mid := Index_Type'Val
(Index_Type'Pos (Lo) +
(Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2);
-- We need to figure out which case we have:
-- x < y < z
-- x < z < y
-- z < x < y
-- y < x < z
-- y < z < x
-- z < y < x
if Is_Less (Lo, Mid) then
if Is_Less (Lo, Hi) then
if Is_Less (Mid, Hi) then
Swap (Lo, Mid);
else
Swap (Lo, Hi);
end if;
else exit when Son > Max;
null; -- lo is median
end if;
elsif Is_Less (Lo, Hi) then declare
null; -- lo is median Son_Index : Index_Type := To_Index (Son);
elsif Is_Less (Mid, Hi) then begin
Swap (Lo, Hi); if Son < Max then
if A (Son_Index) < A (Index_Type'Succ (Son_Index)) then
else Son := Son + 1;
Swap (Lo, Mid); Son_Index := Index_Type'Succ (Son_Index);
end if; end if;
end if;
Pivot := Lo; A (To_Index (C)) := A (Son_Index); -- Move (Son, C);
end;
Outer : loop C := Son;
loop end loop;
exit Outer when not (Pivot < Hi);
if Is_Less (Hi, Pivot) then while C /= S loop
Swap (Hi, Pivot); declare
Pivot := Hi; Father : constant T := C / 2;
Lo := Index_Type'Succ (Lo); Father_Elem : Element_Type renames A (To_Index (Father));
exit;
else
Hi := Index_Type'Pred (Hi);
end if;
end loop;
loop begin
exit Outer when not (Lo < Pivot); if Father_Elem < Temp then -- Lt (Father, 0)
A (To_Index (C)) := Father_Elem; -- Move (Father, C)
C := Father;
if Is_Less (Lo, Pivot) then
Lo := Index_Type'Succ (Lo);
else else
Swap (Lo, Pivot);
Pivot := Lo;
Hi := Index_Type'Pred (Hi);
exit; exit;
end if; end if;
end loop; end;
end loop Outer; end loop;
Sort (First, Index_Type'Pred (Pivot));
Sort (Index_Type'Succ (Pivot), Last);
end Sort;
---------- A (To_Index (C)) := Temp; -- Move (0, C);
-- Swap -- end Sift;
----------
procedure Swap (I, J : Index_Type) is
EI : constant Element_Type := Container (I);
begin
Container (I) := Container (J);
Container (J) := EI;
end Swap;
-- Start of processing for Generic_Constrained_Array_Sort -- Start of processing for Generic_Constrained_Array_Sort
begin begin
Sort (Container'First, Container'Last); for J in reverse 1 .. Max / 2 loop
Temp := Container (To_Index (J)); -- Move (J, 0);
Sift (J);
end loop;
while Max > 1 loop
declare
Max_Elem : Element_Type renames A (To_Index (Max));
begin
Temp := Max_Elem; -- Move (Max, 0);
Max_Elem := A (A'First); -- Move (1, Max);
end;
Max := Max - 1;
Sift (1);
end loop;
end Ada.Containers.Generic_Constrained_Array_Sort; end Ada.Containers.Generic_Constrained_Array_Sort;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment