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 / s-pack51.adb < prev    next >
Text File  |  2000-07-19  |  5KB  |  119 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       S Y S T E M . P A C K _ 5 1                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.2 $
  10. --                                                                          --
  11. --          Copyright (C) 1992-1999 Free Software Foundation, 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 was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with System.Storage_Elements;
  37. with System.Unsigned_Types;
  38. with Unchecked_Conversion;
  39.  
  40. package body System.Pack_51 is
  41.  
  42.    subtype Ofs is System.Storage_Elements.Storage_Offset;
  43.    subtype Uns is System.Unsigned_Types.Unsigned;
  44.    subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
  45.  
  46.    use type System.Storage_Elements.Storage_Offset;
  47.    use type System.Unsigned_Types.Unsigned;
  48.  
  49.    type Cluster is record
  50.       E0, E1, E2, E3, E4, E5, E6, E7 : Bits_51;
  51.    end record;
  52.  
  53.    for Cluster use record
  54.       E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
  55.       E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
  56.       E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
  57.       E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
  58.       E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
  59.       E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
  60.       E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
  61.       E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
  62.    end record;
  63.  
  64.    for Cluster'Size use Bits * 8;
  65.  
  66.    for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
  67.      1 +
  68.      1 * Boolean'Pos (Bits mod 2 = 0) +
  69.      2 * Boolean'Pos (Bits mod 4 = 0));
  70.    --  Use maximum possible alignment, given the bit field size, since this
  71.    --  will result in the most efficient code possible for the field.
  72.  
  73.    type Cluster_Ref is access Cluster;
  74.  
  75.    function To_Ref is new
  76.      Unchecked_Conversion (System.Address, Cluster_Ref);
  77.  
  78.    ------------
  79.    -- Get_51 --
  80.    ------------
  81.  
  82.    function Get_51 (Arr : System.Address; N : Natural) return Bits_51 is
  83.       C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
  84.  
  85.    begin
  86.       case N07 (Uns (N) mod 8) is
  87.          when 0 => return C.E0;
  88.          when 1 => return C.E1;
  89.          when 2 => return C.E2;
  90.          when 3 => return C.E3;
  91.          when 4 => return C.E4;
  92.          when 5 => return C.E5;
  93.          when 6 => return C.E6;
  94.          when 7 => return C.E7;
  95.       end case;
  96.    end Get_51;
  97.  
  98.    ------------
  99.    -- Set_51 --
  100.    ------------
  101.  
  102.    procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51) is
  103.       C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8));
  104.  
  105.    begin
  106.       case N07 (Uns (N) mod 8) is
  107.          when 0 => C.E0 := E;
  108.          when 1 => C.E1 := E;
  109.          when 2 => C.E2 := E;
  110.          when 3 => C.E3 := E;
  111.          when 4 => C.E4 := E;
  112.          when 5 => C.E5 := E;
  113.          when 6 => C.E6 := E;
  114.          when 7 => C.E7 := E;
  115.       end case;
  116.    end Set_51;
  117.  
  118. end System.Pack_51;
  119.