1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                      S Y S T E M . A R I T H _ 3 2                       --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--            Copyright (C) 2020, 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 Ada.Unchecked_Conversion;
33
34package body System.Arith_32 is
35
36   pragma Suppress (Overflow_Check);
37   pragma Suppress (Range_Check);
38
39   subtype Uns32 is Interfaces.Unsigned_32;
40   subtype Uns64 is Interfaces.Unsigned_64;
41
42   use Interfaces;
43
44   function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32);
45
46   -----------------------
47   -- Local Subprograms --
48   -----------------------
49
50   function "abs" (X : Int32) return Uns32 is
51     (if X = Int32'First
52      then 2**31
53      else Uns32 (Int32'(abs X)));
54   --  Convert absolute value of X to unsigned. Note that we can't just use
55   --  the expression of the Else since it overflows for X = Int32'First.
56
57   function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
58   --  High order half of 64-bit value
59
60   function To_Neg_Int (A : Uns32) return Int32;
61   --  Convert to negative integer equivalent. If the input is in the range
62   --  0 .. 2**31, then the corresponding nonpositive signed integer (obtained
63   --  by negating the given value) is returned, otherwise constraint error is
64   --  raised.
65
66   function To_Pos_Int (A : Uns32) return Int32;
67   --  Convert to positive integer equivalent. If the input is in the range
68   --  0 .. 2**31 - 1, then the corresponding nonnegative signed integer is
69   --  returned, otherwise constraint error is raised.
70
71   procedure Raise_Error;
72   pragma No_Return (Raise_Error);
73   --  Raise constraint error with appropriate message
74
75   -----------------
76   -- Raise_Error --
77   -----------------
78
79   procedure Raise_Error is
80   begin
81      raise Constraint_Error with "32-bit arithmetic overflow";
82   end Raise_Error;
83
84   -------------------
85   -- Scaled_Divide --
86   -------------------
87
88   procedure Scaled_Divide32
89     (X, Y, Z : Int32;
90      Q, R    : out Int32;
91      Round   : Boolean)
92   is
93      Xu  : constant Uns32 := abs X;
94      Yu  : constant Uns32 := abs Y;
95      Zu  : constant Uns32 := abs Z;
96
97      D   : Uns64;
98      --  The dividend
99
100      Qu : Uns32;
101      Ru : Uns32;
102      --  Unsigned quotient and remainder
103
104   begin
105      --  First do the 64-bit multiplication
106
107      D := Uns64 (Xu) * Uns64 (Yu);
108
109      --  If dividend is too large, raise error
110
111      if Hi (D) >= Zu then
112         Raise_Error;
113
114      --  Then do the 64-bit division
115
116      else
117         Qu := Uns32 (D / Uns64 (Zu));
118         Ru := Uns32 (D rem Uns64 (Zu));
119      end if;
120
121      --  Deal with rounding case
122
123      if Round and then Ru > (Zu - Uns32'(1)) / Uns32'(2) then
124
125         --  Protect against wrapping around when rounding, by signaling
126         --  an overflow when the quotient is too large.
127
128         if Qu = Uns32'Last then
129            Raise_Error;
130         end if;
131
132         Qu := Qu + Uns32'(1);
133      end if;
134
135      --  Set final signs (RM 4.5.5(27-30))
136
137      --  Case of dividend (X * Y) sign positive
138
139      if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
140         R := To_Pos_Int (Ru);
141         Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
142
143      --  Case of dividend (X * Y) sign negative
144
145      else
146         R := To_Neg_Int (Ru);
147         Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
148      end if;
149   end Scaled_Divide32;
150
151   ----------------
152   -- To_Neg_Int --
153   ----------------
154
155   function To_Neg_Int (A : Uns32) return Int32 is
156      R : constant Int32 :=
157        (if A = 2**31 then Int32'First else -To_Int (A));
158      --  Note that we can't just use the expression of the Else, because it
159      --  overflows for A = 2**31.
160   begin
161      if R <= 0 then
162         return R;
163      else
164         Raise_Error;
165      end if;
166   end To_Neg_Int;
167
168   ----------------
169   -- To_Pos_Int --
170   ----------------
171
172   function To_Pos_Int (A : Uns32) return Int32 is
173      R : constant Int32 := To_Int (A);
174   begin
175      if R >= 0 then
176         return R;
177      else
178         Raise_Error;
179      end if;
180   end To_Pos_Int;
181
182end System.Arith_32;
183