1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                       S Y S T E M . P A C K _ 1 2 7                      --
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_127 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_127;
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   ------------
80   -- Get_127 --
81   ------------
82
83   function Get_127
84     (Arr     : System.Address;
85      N       : Natural;
86      Rev_SSO : Boolean) return Bits_127
87   is
88      A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
89      C  : Cluster_Ref     with Address => A'Address, Import;
90      RC : Rev_Cluster_Ref with Address => A'Address, Import;
91   begin
92      if Rev_SSO then
93         case N07 (Uns (N) mod 8) is
94            when 0 => return RC.E0;
95            when 1 => return RC.E1;
96            when 2 => return RC.E2;
97            when 3 => return RC.E3;
98            when 4 => return RC.E4;
99            when 5 => return RC.E5;
100            when 6 => return RC.E6;
101            when 7 => return RC.E7;
102         end case;
103
104      else
105         case N07 (Uns (N) mod 8) is
106            when 0 => return C.E0;
107            when 1 => return C.E1;
108            when 2 => return C.E2;
109            when 3 => return C.E3;
110            when 4 => return C.E4;
111            when 5 => return C.E5;
112            when 6 => return C.E6;
113            when 7 => return C.E7;
114         end case;
115      end if;
116   end Get_127;
117
118   ------------
119   -- Set_127 --
120   ------------
121
122   procedure Set_127
123     (Arr     : System.Address;
124      N       : Natural;
125      E       : Bits_127;
126      Rev_SSO : Boolean)
127   is
128      A  : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8);
129      C  : Cluster_Ref     with Address => A'Address, Import;
130      RC : Rev_Cluster_Ref with Address => A'Address, Import;
131   begin
132      if Rev_SSO then
133         case N07 (Uns (N) mod 8) is
134            when 0 => RC.E0 := E;
135            when 1 => RC.E1 := E;
136            when 2 => RC.E2 := E;
137            when 3 => RC.E3 := E;
138            when 4 => RC.E4 := E;
139            when 5 => RC.E5 := E;
140            when 6 => RC.E6 := E;
141            when 7 => RC.E7 := E;
142         end case;
143      else
144         case N07 (Uns (N) mod 8) is
145            when 0 => C.E0 := E;
146            when 1 => C.E1 := E;
147            when 2 => C.E2 := E;
148            when 3 => C.E3 := E;
149            when 4 => C.E4 := E;
150            when 5 => C.E5 := E;
151            when 6 => C.E6 := E;
152            when 7 => C.E7 := E;
153         end case;
154      end if;
155   end Set_127;
156
157end System.Pack_127;
158