[thirdparty/gcc.git] / gcc / ada / lib-sort.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . S O R T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2020, Free Software Foundation, Inc.         --
--                                                                          --
-- 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.      --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.Heap_Sort_G;

separate (Lib)
procedure Sort (Tbl : in out Unit_Ref_Table) is

   T : array (0 .. Integer (Tbl'Last - Tbl'First + 1)) of Unit_Number_Type;
   --  Actual sort is done on this copy of the array with 0's origin
   --  subscripts. Location 0 is used as a temporary by the sorting algorithm.
   --  Also the addressing of the table is more efficient with 0's origin,
   --  even though we have to copy Tbl back and forth.

   function Lt_Uname (C1, C2 : Natural) return Boolean;
   --  Comparison routine for comparing Unames. Needed by the sorting routine

   procedure Move_Uname (From : Natural; To : Natural);
   --  Move routine needed by the sorting routine below

   package Sorting is new GNAT.Heap_Sort_G (Move_Uname, Lt_Uname);

   --------------
   -- Lt_Uname --
   --------------

   function Lt_Uname (C1, C2 : Natural) return Boolean is
   begin
      --  Preprocessing data and definition files are not sorted, they are
      --  at the bottom of the list. They are recognized because they are
      --  the only ones without a Unit_Name.

      if Units.Table (T (C1)).Unit_Name = No_Unit_Name then
         return False;

      elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then
         return True;

      else
         return
           Uname_Lt
             (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name);
      end if;
   end Lt_Uname;

   ----------------
   -- Move_Uname --
   ----------------

   procedure Move_Uname (From : Natural; To : Natural) is
   begin
      T (To) := T (From);
   end Move_Uname;

--  Start of processing for Sort

begin
   if T'Last > 0 then
      for I in 1 .. T'Last loop
         T (I) := Tbl (Int (I) - 1 + Tbl'First);
      end loop;

      Sorting.Sort (T'Last);

   --  Sort is complete, copy result back into place

      for I in 1 .. T'Last loop
         Tbl (Int (I) - 1 + Tbl'First) := T (I);
      end loop;
   end if;
end Sort;
Commit	Line	Data
38cbfe40 RK	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT COMPILER COMPONENTS --
	4	-- --
	5	-- L I B . S O R T --
	6	-- --
	7	-- B o d y --
	8	-- --
4b490c1e	9	-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
38cbfe40 RK	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- --
748086b7	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
38cbfe40 RK	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
38cbfe40 RK	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
748086b7 JJ	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/>. --
38cbfe40 RK	26	-- --
38cbfe40 RK	27	-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc	28	-- Extensive contributions were provided by Ada Core Technologies Inc. --
38cbfe40 RK	29	-- --
	30	------------------------------------------------------------------------------
	31
d4731b80	32	with GNAT.Heap_Sort_G;
38cbfe40 RK	33
	34	separate (Lib)
	35	procedure 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;
a2cb348e	44	-- Comparison routine for comparing Unames. Needed by the sorting routine
38cbfe40 RK	45
38cbfe40 RK	46	procedure Move_Uname (From : Natural; To : Natural);
a2cb348e	47	-- Move routine needed by the sorting routine below
38cbfe40	48
d4731b80 BD	49	package Sorting is new GNAT.Heap_Sort_G (Move_Uname, Lt_Uname);
d4731b80 BD	50
38cbfe40 RK	51	--------------
	52	-- Lt_Uname --
	53	--------------
	54
	55	function Lt_Uname (C1, C2 : Natural) return Boolean is
	56	begin
fbf5a39b AC	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
39f4e199	61	if Units.Table (T (C1)).Unit_Name = No_Unit_Name then
fbf5a39b AC	62	return False;
fbf5a39b AC	63
39f4e199	64	elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then
fbf5a39b AC	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;
38cbfe40 RK	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
	85	begin
	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
d4731b80	91	Sorting.Sort (T'Last);
38cbfe40 RK	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;
	99	end Sort;