home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / table.adb < prev    next >
Text File  |  1996-09-28  |  8KB  |  282 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                                T A B L E                                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.19 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Debug;   use Debug;
  27. with Output;  use Output;
  28. with System;  use System;
  29. with Tree_IO; use Tree_IO;
  30. with Unchecked_Conversion;
  31. with Unchecked_Deallocation;
  32.  
  33. package body Table is
  34.  
  35.    Last_Val : Int;
  36.    --  Current value of Last. Note that we declare this in the body because
  37.    --  we don't want the client to modify Last except through one of the
  38.    --  official interfaces (since a modification to Last may require a
  39.    --  reallocation of the table).
  40.  
  41.    Min : Int;
  42.    --  Subscript of the minimum entry in the currently allocated table
  43.  
  44.    Max : Int;
  45.    --  Subscript of the maximum entry in the currently allocated table
  46.  
  47.    Length : Int := 0;
  48.    --  Number of entries in currently allocated table. The value of zero
  49.    --  ensures that we initially allocate the table.
  50.  
  51.    -----------------------
  52.    -- Local Subprograms --
  53.    -----------------------
  54.  
  55.    procedure Reallocate;
  56.    --  Reallocate and extend the existing table
  57.  
  58.  
  59.    --------------
  60.    -- Allocate --
  61.    --------------
  62.  
  63.    function Allocate (Num : Int := 1) return Table_Index_Type is
  64.       Old_Last : constant Int := Last_Val;
  65.  
  66.    begin
  67.       Last_Val := Last_Val + Num;
  68.  
  69.       if Last_Val > Max then
  70.          Reallocate;
  71.       end if;
  72.  
  73.       return Table_Index_Type (Old_Last + 1);
  74.    end Allocate;
  75.  
  76.    ----------
  77.    -- Copy --
  78.    ----------
  79.  
  80.    function Copy return Table_Ptr is
  81.       subtype Local_Table  is Table_Type (Table_Low_Bound .. Last);
  82.       type Local_Table_Ptr is access all Local_Table;
  83.       Tmp : Local_Table_Ptr;
  84.  
  85.       function To_Table_Ptr is
  86.         new Unchecked_Conversion (Local_Table_Ptr, Table_Ptr);
  87.  
  88.    begin
  89.       Tmp := new Local_Table;
  90.       return To_Table_Ptr (Tmp);
  91.    end Copy;
  92.  
  93.    --------------------
  94.    -- Decrement_Last --
  95.    --------------------
  96.  
  97.    procedure Decrement_Last is
  98.    begin
  99.       Last_Val := Last_Val - 1;
  100.    end Decrement_Last;
  101.  
  102.    --------------------
  103.    -- Increment_Last --
  104.    --------------------
  105.  
  106.    procedure Increment_Last is
  107.    begin
  108.       Last_Val := Last_Val + 1;
  109.  
  110.       if Last_Val > Max then
  111.          Reallocate;
  112.       end if;
  113.    end Increment_Last;
  114.  
  115.    ----------
  116.    -- Free --
  117.    ----------
  118.  
  119.    procedure Free (T : in out Table_Ptr) is
  120.       procedure UD is new Unchecked_Deallocation (Big_Table_Type, Table_Ptr);
  121.  
  122.    begin
  123.       UD (T);
  124.    end Free;
  125.  
  126.    ----------
  127.    -- Init --
  128.    ----------
  129.  
  130.    procedure Init is
  131.       Old_Length : Int := Length;
  132.  
  133.    begin
  134.       Min := Int (Table_Low_Bound);
  135.       Last_Val := Min - 1;
  136.       Max := Min + Table_Initial - 1;
  137.       Length := Max - Min + 1;
  138.  
  139.       --  If table is same size as before (happens when table is never
  140.       --  expanded which is a common case), then simply reuse it, else free
  141.       --  the old table and allocate a new one of the proper size.
  142.  
  143.       if Old_Length /= Length then
  144.          Free (Table);
  145.  
  146.          declare
  147.             subtype Local_Table is
  148.               Table_Type (Table_Index_Type (Min) .. Table_Index_Type (Max));
  149.             type Local_Table_Ptr is access all Local_Table;
  150.             Tmp : Local_Table_Ptr;
  151.  
  152.             function To_Table_Ptr is
  153.               new Unchecked_Conversion (Local_Table_Ptr, Table_Ptr);
  154.  
  155.          begin
  156.             Tmp := new Local_Table;
  157.             Table := To_Table_Ptr (Tmp);
  158.          end;
  159.       end if;
  160.    end Init;
  161.  
  162.    ----------
  163.    -- Last --
  164.    ----------
  165.  
  166.    function Last return Table_Index_Type is
  167.    begin
  168.       return Table_Index_Type (Last_Val);
  169.    end Last;
  170.  
  171.    ----------------
  172.    -- Reallocate --
  173.    ----------------
  174.  
  175.    procedure Reallocate is
  176.       Old_Table : Table_Ptr := Table;
  177.       Old_Max   : Int := Max;
  178.  
  179.    begin
  180.       if Table_Increment = 0 then
  181.          Write_Str ("Fatal error, table ");
  182.          Write_Str (Table_Name);
  183.          Write_Str (" capacity exceeded");
  184.          Write_Eol;
  185.          raise Unrecoverable_Error;
  186.       end if;
  187.  
  188.       while Max < Last_Val loop
  189.          Length := Length * (100 + Table_Increment) / 100;
  190.          Max := Min + Length - 1;
  191.       end loop;
  192.  
  193.       declare
  194.          subtype Local_Table is
  195.            Table_Type (Table_Index_Type (Min) .. Table_Index_Type (Max));
  196.          type Local_Table_Ptr is access all Local_Table;
  197.          Tmp : Local_Table_Ptr;
  198.  
  199.          --  We allocate an array of the bounds we want (Local_Table) and
  200.          --  then use unchecked conversion to convert this to the fake
  201.          --  pointer to giant array type that we use for access. This is
  202.          --  done to allow efficient thin pointer access to the table with
  203.          --  a fixed and known lower bound.
  204.  
  205.          function To_Table_Ptr is
  206.            new Unchecked_Conversion (Local_Table_Ptr, Table_Ptr);
  207.  
  208.       begin
  209.          Tmp   := new Local_Table;
  210.          Table := To_Table_Ptr (Tmp);
  211.       end;
  212.  
  213.       if Debug_Flag_D then
  214.          Write_Str ("--> Allocating new ");
  215.          Write_Str (Table_Name);
  216.          Write_Str (" table, size = ");
  217.          Write_Int (Max - Min + 1);
  218.          Write_Eol;
  219.       end if;
  220.  
  221.       for J in Min .. Old_Max loop
  222.          Table (Table_Index_Type (J)) := Old_Table (Table_Index_Type (J));
  223.       end loop;
  224.  
  225.       Free (Old_Table);
  226.    end Reallocate;
  227.  
  228.    --------------
  229.    -- Set_Last --
  230.    --------------
  231.  
  232.    procedure Set_Last (New_Val : Table_Index_Type) is
  233.       Old_Last : Int;
  234.  
  235.    begin
  236.       if Int (New_Val) < Last_Val then
  237.          Last_Val := Int (New_Val);
  238.       else
  239.          Old_Last := Last_Val;
  240.          Last_Val := Int (New_Val);
  241.  
  242.          if Last_Val > Max then
  243.             Reallocate;
  244.          end if;
  245.       end if;
  246.    end Set_Last;
  247.  
  248.    ---------------
  249.    -- Tree_Read --
  250.    ---------------
  251.  
  252.    procedure Tree_Read is
  253.       N : Int;
  254.  
  255.    begin
  256.       Tree_Read_Int (N);
  257.       Set_Last (Table_Index_Type (N));
  258.  
  259.       Tree_Read_Data
  260.         (Table (First)'Address,
  261.          (Last_Val - Int (First) + 1) *
  262.            Table_Component_Type'Size / Storage_Unit);
  263.    end Tree_Read;
  264.  
  265.    ----------------
  266.    -- Tree_Write --
  267.    ----------------
  268.  
  269.    procedure Tree_Write is
  270.  
  271.    begin
  272.       Tree_Write_Int (Int (Last));
  273.       Tree_Write_Data
  274.         (Table (First)'Address,
  275.          (Last_Val - Int (First) + 1) *
  276.            Table_Component_Type'Size / Storage_Unit);
  277.    end Tree_Write;
  278.  
  279. begin
  280.    Init;
  281. end Table;
  282.