===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1998-2013, 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- --
@@ -29,6 +29,8 @@
-- --
------------------------------------------------------------------------------
+with GNAT.Heap_Sort_G;
+
with System; use System;
with System.Memory; use System.Memory;
@@ -114,6 +116,19 @@
Last_Val := Last_Val - 1;
end Decrement_Last;
+ --------------
+ -- For_Each --
+ --------------
+
+ procedure For_Each is
+ Quit : Boolean := False;
+ begin
+ for Index in Table_Low_Bound .. Table_Index_Type (Last_Val) loop
+ Action (Index, Table (Index), Quit);
+ exit when Quit;
+ end loop;
+ end For_Each;
+
----------
-- Free --
----------
@@ -259,17 +274,17 @@
pragma Import (Ada, Allocated_Table);
pragma Suppress (Range_Check, On => Allocated_Table);
for Allocated_Table'Address use Allocated_Table_Address;
- -- Allocated_Table represents the currently allocated array, plus
- -- one element (the supplementary element is used to have a
- -- convenient way of computing the address just past the end of the
- -- current allocation). Range checks are suppressed because this unit
- -- uses direct calls to System.Memory for allocation, and this can
- -- yield misaligned storage (and we cannot rely on the bootstrap
- -- compiler supporting specifically disabling alignment checks, so we
- -- need to suppress all range checks). It is safe to suppress this check
- -- here because we know that a (possibly misaligned) object of that type
- -- does actually exist at that address.
- -- ??? We should really improve the allocation circuitry here to
+ -- Allocated_Table represents the currently allocated array, plus one
+ -- element (the supplementary element is used to have a convenient
+ -- way of computing the address just past the end of the current
+ -- allocation). Range checks are suppressed because this unit uses
+ -- direct calls to System.Memory for allocation, and this can yield
+ -- misaligned storage (and we cannot rely on the bootstrap compiler
+ -- supporting specifically disabling alignment checks, so we need to
+ -- suppress all range checks). It is safe to suppress this check here
+ -- because we know that a (possibly misaligned) object of that type
+ -- does actually exist at that address. ??? We should really improve
+ -- the allocation circuitry here to
-- guarantee proper alignment.
Need_Realloc : constant Boolean := Integer (Index) > Max;
@@ -324,6 +339,74 @@
end if;
end Set_Last;
+ ----------------
+ -- Sort_Table --
+ ----------------
+
+ procedure Sort_Table is
+
+ Temp : Table_Component_Type;
+ -- A temporary position to simulate index 0
+
+ -- Local subprograms
+
+ function Index_Of (Idx : Natural) return Table_Index_Type;
+ -- Return index of Idx'th element of table
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean;
+ -- Compare two components
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move one component
+
+ package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
+
+ --------------
+ -- Index_Of --
+ --------------
+
+ function Index_Of (Idx : Natural) return Table_Index_Type is
+ J : constant Integer'Base := Table_Index_Type'Pos (First) + Idx - 1;
+ begin
+ return Table_Index_Type'Val (J);
+ end Index_Of;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ if From = 0 then
+ Table (Index_Of (To)) := Temp;
+ elsif To = 0 then
+ Temp := Table (Index_Of (From));
+ else
+ Table (Index_Of (To)) := Table (Index_Of (From));
+ end if;
+ end Move;
+
+ ----------------
+ -- Lower_Than --
+ ----------------
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Lt (Temp, Table (Index_Of (Op2)));
+ elsif Op2 = 0 then
+ return Lt (Table (Index_Of (Op1)), Temp);
+ else
+ return Lt (Table (Index_Of (Op1)), Table (Index_Of (Op2)));
+ end if;
+ end Lower_Than;
+
+ -- Start of processing for Sort_Table
+
+ begin
+ Heap_Sort.Sort (Natural (Last - First) + 1);
+ end Sort_Table;
+
begin
Init;
end GNAT.Table;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1998-2013, 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- --
@@ -201,4 +201,25 @@
-- This means that a reference X.Table (X.Allocate) is incorrect, since
-- the call to X.Allocate may modify the results of calling X.Table.
+ generic
+ with procedure Action
+ (Index : Table_Index_Type;
+ Item : Table_Component_Type;
+ Quit : in out Boolean) is <>;
+ procedure For_Each;
+ -- Calls procedure Action for each component of the table, or until
+ -- one of these calls set Quit to True.
+
+ generic
+ with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
+ procedure Sort_Table;
+ -- This procedure sorts the components of the table into ascending
+ -- order making calls to Lt to do required comparisons, and using
+ -- assignments to move components around. The Lt function returns True
+ -- if Comp1 is less than Comp2 (in the sense of the desired sort), and
+ -- False if Comp1 is greater than Comp2. For equal objects it does not
+ -- matter if True or False is returned (it is slightly more efficient
+ -- to return False). The sort is not stable (the order of equal items
+ -- in the table is not preserved).
+
end GNAT.Table;
This patch adds the procedures For_Each and Sort_Table to GNAT.Table making its interface more similar to that of GNAT.Dynamic_Tables. The following test: 1. with GNAT.Table; 2. with Text_IO; use Text_IO; 3. procedure GTableTestFS is 4. package T is new GNAT.Table 5. (Table_Component_Type => Integer, 6. Table_Index_Type => Natural, 7. Table_Low_Bound => 1, 8. Table_Initial => 3, 9. Table_Increment => 100); 10. 11. procedure Action 12. (Index : Natural; 13. Item : Integer; 14. Quit : in out Boolean) 15. is 16. begin 17. Put_Line (Item'Img); 18. Quit := Item = 40; 19. end Action; 20. 21. procedure For_Each is new T.For_Each (Action); 22. procedure Sort_Table is new T.Sort_Table ("<"); 23. 24. begin 25. T.Init; 26. T.Append (60); 27. T.Append (50); 28. T.Append (40); 29. T.Append (30); 30. T.Append (20); 31. T.Append (10); 32. 33. For_Each; 34. Sort_Table; 35. For_Each; 36. end GTableTestFS; when run, generates the output 60 50 40 10 20 30 40 Tested on x86_64-pc-linux-gnu, committed on trunk 2013-09-10 Robert Dewar <dewar@adacore.com> * g-table.ads, g-table.adb (For_Each): New generic procedure (Sort_Table): New generic procedure.