gcc/ada/libgnat/s-pack42.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . P A C K _ 4 2                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
  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- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  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/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Storage_Elements;
  33 with System.Unsigned_Types;
  34
  35 package body System.Pack_42 is
  36
  37    subtype Bit_Order is System.Bit_Order;
  38    Reverse_Bit_Order : constant Bit_Order :=
  39      Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order));
  40
  41    subtype Ofs is System.Storage_Elements.Storage_Offset;
  42    subtype Uns is System.Unsigned_Types.Unsigned;
  43    subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7;
  44
  45    use type System.Storage_Elements.Storage_Offset;
  46    use type System.Unsigned_Types.Unsigned;
  47
  48    type Cluster is record
  49       E0, E1, E2, E3, E4, E5, E6, E7 : Bits_42;
  50    end record;
  51
  52    for Cluster use record
  53       E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1;
  54       E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1;
  55       E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1;
  56       E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1;
  57       E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1;
  58       E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1;
  59       E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1;
  60       E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1;
  61    end record;
  62
  63    for Cluster'Size use Bits * 8;
  64
  65    for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment,
  66      1 +
  67      1 * Boolean'Pos (Bits mod 2 = 0) +
  68      2 * Boolean'Pos (Bits mod 4 = 0));
  69    --  Use maximum possible alignment, given the bit field size, since this
  70    --  will result in the most efficient code possible for the field.
  71
  72    type Cluster_Ref is access Cluster;
  73
  74    type Rev_Cluster is new Cluster
  75      with Bit_Order            => Reverse_Bit_Order,
  76           Scalar_Storage_Order => Reverse_Bit_Order;
  77    type Rev_Cluster_Ref is access Rev_Cluster;
  78
  79    --  The following declarations are for the case where the address
  80    --  passed to GetU_42 or SetU_42 is not guaranteed to be aligned.
  81    --  These routines are used when the packed array is itself a
  82    --  component of a packed record, and therefore may not be aligned.
  83
  84    type ClusterU is new Cluster;
  85    for ClusterU'Alignment use 1;
  86
  87    type ClusterU_Ref is access ClusterU;
  88
  89    type Rev_ClusterU is new ClusterU
  90      with Bit_Order            => Reverse_Bit_Order,
  91           Scalar_Storage_Order => Reverse_Bit_Order;
  92    type Rev_ClusterU_Ref is access Rev_ClusterU;
  93
  94    ------------
  95    -- Get_42 --
  96    ------------
  97
  98    function Get_42
  99      (Arr     : System.Address;
 100       N       : Natural;
 101       Rev_SSO : Boolean) return Bits_42
 102    is
 103       A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
 104       C  : Cluster_Ref     with Address => A'Address, Import;
 105       RC : Rev_Cluster_Ref with Address => A'Address, Import;
 106    begin
 107       if Rev_SSO then
 108          case N07 (Uns (N) mod 8) is
 109             when 0 => return RC.E0;
 110             when 1 => return RC.E1;
 111             when 2 => return RC.E2;
 112             when 3 => return RC.E3;
 113             when 4 => return RC.E4;
 114             when 5 => return RC.E5;
 115             when 6 => return RC.E6;
 116             when 7 => return RC.E7;
 117          end case;
 118
 119       else
 120          case N07 (Uns (N) mod 8) is
 121             when 0 => return C.E0;
 122             when 1 => return C.E1;
 123             when 2 => return C.E2;
 124             when 3 => return C.E3;
 125             when 4 => return C.E4;
 126             when 5 => return C.E5;
 127             when 6 => return C.E6;
 128             when 7 => return C.E7;
 129          end case;
 130       end if;
 131    end Get_42;
 132
 133    -------------
 134    -- GetU_42 --
 135    -------------
 136
 137    function GetU_42
 138      (Arr     : System.Address;
 139       N       : Natural;
 140       Rev_SSO : Boolean) return Bits_42
 141    is
 142       A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
 143       C  : ClusterU_Ref     with Address => A'Address, Import;
 144       RC : Rev_ClusterU_Ref with Address => A'Address, Import;
 145    begin
 146       if Rev_SSO then
 147          case N07 (Uns (N) mod 8) is
 148             when 0 => return RC.E0;
 149             when 1 => return RC.E1;
 150             when 2 => return RC.E2;
 151             when 3 => return RC.E3;
 152             when 4 => return RC.E4;
 153             when 5 => return RC.E5;
 154             when 6 => return RC.E6;
 155             when 7 => return RC.E7;
 156          end case;
 157
 158       else
 159          case N07 (Uns (N) mod 8) is
 160             when 0 => return C.E0;
 161             when 1 => return C.E1;
 162             when 2 => return C.E2;
 163             when 3 => return C.E3;
 164             when 4 => return C.E4;
 165             when 5 => return C.E5;
 166             when 6 => return C.E6;
 167             when 7 => return C.E7;
 168          end case;
 169       end if;
 170    end GetU_42;
 171
 172    ------------
 173    -- Set_42 --
 174    ------------
 175
 176    procedure Set_42
 177      (Arr     : System.Address;
 178       N       : Natural;
 179       E       : Bits_42;
 180       Rev_SSO : Boolean)
 181    is
 182       A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
 183       C  : Cluster_Ref     with Address => A'Address, Import;
 184       RC : Rev_Cluster_Ref with Address => A'Address, Import;
 185    begin
 186       if Rev_SSO then
 187          case N07 (Uns (N) mod 8) is
 188             when 0 => RC.E0 := E;
 189             when 1 => RC.E1 := E;
 190             when 2 => RC.E2 := E;
 191             when 3 => RC.E3 := E;
 192             when 4 => RC.E4 := E;
 193             when 5 => RC.E5 := E;
 194             when 6 => RC.E6 := E;
 195             when 7 => RC.E7 := E;
 196          end case;
 197       else
 198          case N07 (Uns (N) mod 8) is
 199             when 0 => C.E0 := E;
 200             when 1 => C.E1 := E;
 201             when 2 => C.E2 := E;
 202             when 3 => C.E3 := E;
 203             when 4 => C.E4 := E;
 204             when 5 => C.E5 := E;
 205             when 6 => C.E6 := E;
 206             when 7 => C.E7 := E;
 207          end case;
 208       end if;
 209    end Set_42;
 210
 211    -------------
 212    -- SetU_42 --
 213    -------------
 214
 215    procedure SetU_42
 216      (Arr     : System.Address;
 217       N       : Natural;
 218       E       : Bits_42;
 219       Rev_SSO : Boolean)
 220    is
 221       A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
 222       C  : ClusterU_Ref     with Address => A'Address, Import;
 223       RC : Rev_ClusterU_Ref with Address => A'Address, Import;
 224    begin
 225       if Rev_SSO then
 226          case N07 (Uns (N) mod 8) is
 227             when 0 => RC.E0 := E;
 228             when 1 => RC.E1 := E;
 229             when 2 => RC.E2 := E;
 230             when 3 => RC.E3 := E;
 231             when 4 => RC.E4 := E;
 232             when 5 => RC.E5 := E;
 233             when 6 => RC.E6 := E;
 234             when 7 => RC.E7 := E;
 235          end case;
 236       else
 237          case N07 (Uns (N) mod 8) is
 238             when 0 => C.E0 := E;
 239             when 1 => C.E1 := E;
 240             when 2 => C.E2 := E;
 241             when 3 => C.E3 := E;
 242             when 4 => C.E4 := E;
 243             when 5 => C.E5 := E;
 244             when 6 => C.E6 := E;
 245             when 7 => C.E7 := E;
 246          end case;
 247       end if;
 248    end SetU_42;
 249
 250 end System.Pack_42;