1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.GENERIC_SORT -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30-- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) 31 32with System; 33 34procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is 35 type T is range System.Min_Int .. System.Max_Int; 36 37 function To_Index (J : T) return Index_Type; 38 pragma Inline (To_Index); 39 40 function Lt (J, K : T) return Boolean; 41 pragma Inline (Lt); 42 43 procedure Xchg (J, K : T); 44 pragma Inline (Xchg); 45 46 procedure Sift (S : T); 47 48 -------------- 49 -- To_Index -- 50 -------------- 51 52 function To_Index (J : T) return Index_Type is 53 K : constant T'Base := Index_Type'Pos (First) + J - T'(1); 54 begin 55 return Index_Type'Val (K); 56 end To_Index; 57 58 -------- 59 -- Lt -- 60 -------- 61 62 function Lt (J, K : T) return Boolean is 63 begin 64 return Before (To_Index (J), To_Index (K)); 65 end Lt; 66 67 ---------- 68 -- Xchg -- 69 ---------- 70 71 procedure Xchg (J, K : T) is 72 begin 73 Swap (To_Index (J), To_Index (K)); 74 end Xchg; 75 76 Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1); 77 78 ---------- 79 -- Sift -- 80 ---------- 81 82 procedure Sift (S : T) is 83 C : T := S; 84 Son : T; 85 Father : T; 86 87 begin 88 loop 89 Son := C + C; 90 91 if Son < Max then 92 if Lt (Son, Son + 1) then 93 Son := Son + 1; 94 end if; 95 elsif Son > Max then 96 exit; 97 end if; 98 99 Xchg (Son, C); 100 C := Son; 101 end loop; 102 103 while C /= S loop 104 Father := C / 2; 105 106 if Lt (Father, C) then 107 Xchg (Father, C); 108 C := Father; 109 else 110 exit; 111 end if; 112 end loop; 113 end Sift; 114 115-- Start of processing for Generic_Sort 116 117begin 118 for J in reverse 1 .. Max / 2 loop 119 Sift (J); 120 end loop; 121 122 while Max > 1 loop 123 Xchg (1, Max); 124 Max := Max - 1; 125 Sift (1); 126 end loop; 127end Ada.Containers.Generic_Sort; 128