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