home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / g-table.adb < prev    next >
Text File  |  2000-07-19  |  7KB  |  230 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                            G N A T .  T A B L E                          --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.6 $
  10. --                                                                          --
  11. --            Copyright (C) 1998-1999 Ada Core Technologies, Inc.           --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  32. --                                                                          --
  33. ------------------------------------------------------------------------------
  34.  
  35. with System; use System;
  36.  
  37. package body GNAT.Table is
  38.  
  39.    Min : constant Integer := Integer (Table_Low_Bound);
  40.    --  Subscript of the minimum entry in the currently allocated table
  41.  
  42.    Max : Integer;
  43.    --  Subscript of the maximum entry in the currently allocated table
  44.  
  45.    Length : Integer := 0;
  46.    --  Number of entries in currently allocated table. The value of zero
  47.    --  ensures that we initially allocate the table.
  48.  
  49.    Last_Val : Integer;
  50.    --  Current value of Last.
  51.  
  52.    type size_t is new Integer;
  53.  
  54.    -----------------------
  55.    -- Local Subprograms --
  56.    -----------------------
  57.  
  58.    procedure Reallocate;
  59.    --  Reallocate the existing table according to the current value stored
  60.    --  in Max. Works correctly to do an initial allocation if the table
  61.    --  is currently null.
  62.  
  63.    --------------
  64.    -- Allocate --
  65.    --------------
  66.  
  67.    function Allocate (Num : Integer := 1) return Table_Index_Type is
  68.       Old_Last : constant Integer := Last_Val;
  69.  
  70.    begin
  71.       Last_Val := Last_Val + Num;
  72.  
  73.       if Last_Val > Max then
  74.          Reallocate;
  75.       end if;
  76.  
  77.       return Table_Index_Type (Old_Last + 1);
  78.    end Allocate;
  79.  
  80.    --------------------
  81.    -- Decrement_Last --
  82.    --------------------
  83.  
  84.    procedure Decrement_Last is
  85.    begin
  86.       Last_Val := Last_Val - 1;
  87.    end Decrement_Last;
  88.  
  89.    --------------------
  90.    -- Increment_Last --
  91.    --------------------
  92.  
  93.    procedure Increment_Last is
  94.    begin
  95.       Last_Val := Last_Val + 1;
  96.  
  97.       if Last_Val > Max then
  98.          Reallocate;
  99.       end if;
  100.    end Increment_Last;
  101.  
  102.    ----------
  103.    -- Init --
  104.    ----------
  105.  
  106.    procedure Init is
  107.       Old_Length : Integer := Length;
  108.  
  109.    begin
  110.       Last_Val := Min - 1;
  111.       Max      := Min + Table_Initial - 1;
  112.       Length   := Max - Min + 1;
  113.  
  114.       --  If table is same size as before (happens when table is never
  115.       --  expanded which is a common case), then simply reuse it. Note
  116.       --  that this also means that an explicit Init call right after
  117.       --  the implicit one in the package body is harmless.
  118.  
  119.       if Old_Length = Length then
  120.          return;
  121.  
  122.       --  Otherwise we can use Reallocate to get a table of the right size.
  123.       --  Note that Reallocate works fine to allocate a table of the right
  124.       --  initial size when it is first allocated.
  125.  
  126.       else
  127.          Reallocate;
  128.       end if;
  129.    end Init;
  130.  
  131.    ----------
  132.    -- Last --
  133.    ----------
  134.  
  135.    function Last return Table_Index_Type is
  136.    begin
  137.       return Table_Index_Type (Last_Val);
  138.    end Last;
  139.  
  140.    ----------------
  141.    -- Reallocate --
  142.    ----------------
  143.  
  144.    procedure Reallocate is
  145.  
  146.       function realloc
  147.         (memblock : Table_Ptr;
  148.          size     : size_t)
  149.          return     Table_Ptr;
  150.       pragma Import (C, realloc);
  151.  
  152.       function malloc
  153.         (size     : size_t)
  154.          return     Table_Ptr;
  155.       pragma Import (C, malloc);
  156.  
  157.       New_Size : size_t;
  158.  
  159.    begin
  160.       if Max < Last_Val then
  161.          pragma Assert (not Locked);
  162.  
  163.          while Max < Last_Val loop
  164.  
  165.             --  Increase length using the table increment factor, but make
  166.             --  sure that we add at least ten elements (this avoids a loop
  167.             --  for silly small increment values)
  168.  
  169.             Length := Integer'Max
  170.                         (Length * (100 + Table_Increment) / 100,
  171.                          Length + 10);
  172.             Max := Min + Length - 1;
  173.          end loop;
  174.       end if;
  175.  
  176.       New_Size :=
  177.         size_t ((Max - Min + 1) *
  178.                 (Table_Type'Component_Size / Storage_Unit));
  179.  
  180.       if Table = null then
  181.          Table := malloc (New_Size);
  182.  
  183.       elsif New_Size > 0 then
  184.          Table :=
  185.            realloc
  186.              (memblock => Table,
  187.               size     => New_Size);
  188.       end if;
  189.  
  190.       if Length /= 0 and then Table = null then
  191.          raise Storage_Error;
  192.       end if;
  193.  
  194.    end Reallocate;
  195.  
  196.    -------------
  197.    -- Release --
  198.    -------------
  199.  
  200.    procedure Release is
  201.    begin
  202.       Length := Last_Val - Integer (Table_Low_Bound) + 1;
  203.       Max    := Last_Val;
  204.       Reallocate;
  205.    end Release;
  206.  
  207.    --------------
  208.    -- Set_Last --
  209.    --------------
  210.  
  211.    procedure Set_Last (New_Val : Table_Index_Type) is
  212.       Old_Last : Integer;
  213.  
  214.    begin
  215.       if Integer (New_Val) < Last_Val then
  216.          Last_Val := Integer (New_Val);
  217.       else
  218.          Old_Last := Last_Val;
  219.          Last_Val := Integer (New_Val);
  220.  
  221.          if Last_Val > Max then
  222.             Reallocate;
  223.          end if;
  224.       end if;
  225.    end Set_Last;
  226.  
  227. begin
  228.    Init;
  229. end GNAT.Table;
  230.