1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I B . S O R T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009, 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-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with GNAT.Heap_Sort_G; 33 34separate (Lib) 35procedure Sort (Tbl : in out Unit_Ref_Table) is 36 37 T : array (0 .. Integer (Tbl'Last - Tbl'First + 1)) of Unit_Number_Type; 38 -- Actual sort is done on this copy of the array with 0's origin 39 -- subscripts. Location 0 is used as a temporary by the sorting algorithm. 40 -- Also the addressing of the table is more efficient with 0's origin, 41 -- even though we have to copy Tbl back and forth. 42 43 function Lt_Uname (C1, C2 : Natural) return Boolean; 44 -- Comparison routine for comparing Unames. Needed by the sorting routine 45 46 procedure Move_Uname (From : Natural; To : Natural); 47 -- Move routine needed by the sorting routine below 48 49 package Sorting is new GNAT.Heap_Sort_G (Move_Uname, Lt_Uname); 50 51 -------------- 52 -- Lt_Uname -- 53 -------------- 54 55 function Lt_Uname (C1, C2 : Natural) return Boolean is 56 begin 57 -- Preprocessing data and definition files are not sorted, they are 58 -- at the bottom of the list. They are recognized because they are 59 -- the only ones without a Unit_Name. 60 61 if Units.Table (T (C1)).Unit_Name = No_Unit_Name then 62 return False; 63 64 elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then 65 return True; 66 67 else 68 return 69 Uname_Lt 70 (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name); 71 end if; 72 end Lt_Uname; 73 74 ---------------- 75 -- Move_Uname -- 76 ---------------- 77 78 procedure Move_Uname (From : Natural; To : Natural) is 79 begin 80 T (To) := T (From); 81 end Move_Uname; 82 83-- Start of processing for Sort 84 85begin 86 if T'Last > 0 then 87 for I in 1 .. T'Last loop 88 T (I) := Tbl (Int (I) - 1 + Tbl'First); 89 end loop; 90 91 Sorting.Sort (T'Last); 92 93 -- Sort is complete, copy result back into place 94 95 for I in 1 .. T'Last loop 96 Tbl (Int (I) - 1 + Tbl'First) := T (I); 97 end loop; 98 end if; 99end Sort; 100