112657Skvn------------------------------------------------------------------------------ 212657Skvn-- -- 312657Skvn-- GNAT RUN-TIME COMPONENTS -- 412657Skvn-- -- 512657Skvn-- S Y S T E M . P A C K _ 4 2 -- 612657Skvn-- -- 712657Skvn-- B o d y -- 812657Skvn-- -- 912657Skvn-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- 1012657Skvn-- -- 1112657Skvn-- GNAT is free software; you can redistribute it and/or modify it under -- 1212657Skvn-- terms of the GNU General Public License as published by the Free Soft- -- 1312657Skvn-- ware Foundation; either version 3, or (at your option) any later ver- -- 1412657Skvn-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 1512657Skvn-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 1612657Skvn-- or FITNESS FOR A PARTICULAR PURPOSE. -- 1712657Skvn-- -- 1812657Skvn-- As a special exception under Section 7 of GPL version 3, you are granted -- 1912657Skvn-- additional permissions described in the GCC Runtime Library Exception, -- 2012657Skvn-- version 3.1, as published by the Free Software Foundation. -- 2112657Skvn-- -- 2212657Skvn-- You should have received a copy of the GNU General Public License and -- 2312657Skvn-- a copy of the GCC Runtime Library Exception along with this program; -- 2412657Skvn-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 2512657Skvn-- <http://www.gnu.org/licenses/>. -- 2612657Skvn-- -- 2712657Skvn-- GNAT was originally developed by the GNAT team at New York University. -- 2812657Skvn-- Extensive contributions were provided by Ada Core Technologies Inc. -- 2912657Skvn-- -- 3012657Skvn------------------------------------------------------------------------------ 3112657Skvn 3212657Skvnwith System.Storage_Elements; 3312657Skvnwith System.Unsigned_Types; 3412657Skvn 3512657Skvnpackage body System.Pack_42 is 3612657Skvn 3712657Skvn subtype Bit_Order is System.Bit_Order; 3812657Skvn Reverse_Bit_Order : constant Bit_Order := 3912657Skvn Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); 4012657Skvn 4112657Skvn subtype Ofs is System.Storage_Elements.Storage_Offset; 4212657Skvn subtype Uns is System.Unsigned_Types.Unsigned; 4312657Skvn subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; 4412657Skvn 4512657Skvn use type System.Storage_Elements.Storage_Offset; 4612657Skvn use type System.Unsigned_Types.Unsigned; 4712657Skvn 4812657Skvn type Cluster is record 4912657Skvn E0, E1, E2, E3, E4, E5, E6, E7 : Bits_42; 5012657Skvn end record; 5112657Skvn 5212657Skvn for Cluster use record 5312657Skvn E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; 5412657Skvn E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; 5512657Skvn E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; 5612657Skvn E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; 5712657Skvn E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; 5812657Skvn E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; 5912657Skvn E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; 6012657Skvn E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; 6112657Skvn end record; 6212657Skvn 6312657Skvn for Cluster'Size use Bits * 8; 6412657Skvn 6512657Skvn for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, 6612657Skvn 1 + 6712657Skvn 1 * Boolean'Pos (Bits mod 2 = 0) + 6812657Skvn 2 * Boolean'Pos (Bits mod 4 = 0)); 6912657Skvn -- Use maximum possible alignment, given the bit field size, since this 7012657Skvn -- will result in the most efficient code possible for the field. 7112657Skvn 7212657Skvn type Cluster_Ref is access Cluster; 7312657Skvn 7412657Skvn type Rev_Cluster is new Cluster 7512657Skvn with Bit_Order => Reverse_Bit_Order, 7612657Skvn Scalar_Storage_Order => Reverse_Bit_Order; 7712657Skvn type Rev_Cluster_Ref is access Rev_Cluster; 7812657Skvn 7912657Skvn -- The following declarations are for the case where the address 8012657Skvn -- passed to GetU_42 or SetU_42 is not guaranteed to be aligned. 8112657Skvn -- These routines are used when the packed array is itself a 8212657Skvn -- component of a packed record, and therefore may not be aligned. 8312657Skvn 8412657Skvn type ClusterU is new Cluster; 8512657Skvn 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 250end System.Pack_42; 251