GCC v8.2
[gcc.git] / gcc / ada / libgnat / s-pack49.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT RUN-TIME COMPONENTS                         --
4 --                                                                          --
5 --                       S Y S T E M . P A C K _ 4 9                        --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2018, 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_49 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_49;
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_49 --
81    ------------
82
83    function Get_49
84      (Arr     : System.Address;
85       N       : Natural;
86       Rev_SSO : Boolean) return Bits_49
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_49;
117
118    ------------
119    -- Set_49 --
120    ------------
121
122    procedure Set_49
123      (Arr     : System.Address;
124       N       : Natural;
125       E       : Bits_49;
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_49;
156
157 end System.Pack_49;