1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . P A C K _ 1 8 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, 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 32with System.Storage_Elements; 33with System.Unsigned_Types; 34 35package body System.Pack_18 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_18; 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_18 or SetU_18 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_18 -- 96 ------------ 97 98 function Get_18 99 (Arr : System.Address; 100 N : Natural; 101 Rev_SSO : Boolean) return Bits_18 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_18; 132 133 ------------- 134 -- GetU_18 -- 135 ------------- 136 137 function GetU_18 138 (Arr : System.Address; 139 N : Natural; 140 Rev_SSO : Boolean) return Bits_18 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_18; 171 172 ------------ 173 -- Set_18 -- 174 ------------ 175 176 procedure Set_18 177 (Arr : System.Address; 178 N : Natural; 179 E : Bits_18; 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_18; 210 211 ------------- 212 -- SetU_18 -- 213 ------------- 214 215 procedure SetU_18 216 (Arr : System.Address; 217 N : Natural; 218 E : Bits_18; 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_18; 249 250end System.Pack_18; 251