1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . S C A L A R _ V A L U E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2003-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.Scalar_Values is 35 36 use Interfaces; 37 38 ---------------- 39 -- Initialize -- 40 ---------------- 41 42 procedure Initialize (Mode1 : Character; Mode2 : Character) is 43 C1 : Character := Mode1; 44 C2 : Character := Mode2; 45 46 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); 47 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); 48 49 subtype String2 is String (1 .. 2); 50 type String2_Ptr is access all String2; 51 52 Env_Value_Ptr : aliased String2_Ptr; 53 Env_Value_Length : aliased Integer; 54 55 EV_Val : aliased constant String := 56 "GNAT_INIT_SCALARS" & ASCII.NUL; 57 58 B : Byte1; 59 60 EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size; 61 -- Set True if we are on an x86 with 96-bit floats for extended 62 63 AFloat : constant Boolean := 64 Long_Float'Size = 48 and then Long_Long_Float'Size = 48; 65 -- Set True if we are on an AAMP with 48-bit extended floating point 66 67 type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1; 68 69 for ByteLF'Component_Size use 8; 70 71 -- Type used to hold Long_Float values on all targets and to initialize 72 -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes. 73 -- On other targets the type is 8 bytes, and type Byte8 is used for 74 -- values that are then converted to ByteLF. 75 76 pragma Warnings (Off); -- why ??? 77 function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF); 78 pragma Warnings (On); 79 80 type ByteLLF is 81 array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat)) 82 of Byte1; 83 84 for ByteLLF'Component_Size use 8; 85 86 -- Type used to initialize Long_Long_Float values used on x86 and 87 -- any other target with the same 80-bit floating-point values that 88 -- GCC always stores in 96-bits. Note that we are assuming Intel 89 -- format little-endian addressing for this type. On non-Intel 90 -- architectures, this is the same length as Byte8 and holds 91 -- a Long_Float value. 92 93 -- The following variables are used to initialize the float values 94 -- by overlay. We can't assign directly to the float values, since 95 -- we may be assigning signalling Nan's that will cause a trap if 96 -- loaded into a floating-point register. 97 98 IV_Isf : aliased Byte4; -- Initialize short float 99 IV_Ifl : aliased Byte4; -- Initialize float 100 IV_Ilf : aliased ByteLF; -- Initialize long float 101 IV_Ill : aliased ByteLLF; -- Initialize long long float 102 103 for IV_Isf'Address use IS_Isf'Address; 104 for IV_Ifl'Address use IS_Ifl'Address; 105 for IV_Ilf'Address use IS_Ilf'Address; 106 for IV_Ill'Address use IS_Ill'Address; 107 108 -- The following pragmas are used to suppress initialization 109 110 pragma Import (Ada, IV_Isf); 111 pragma Import (Ada, IV_Ifl); 112 pragma Import (Ada, IV_Ilf); 113 pragma Import (Ada, IV_Ill); 114 115 begin 116 -- Acquire environment variable value if necessary 117 118 if C1 = 'E' and then C2 = 'V' then 119 Get_Env_Value_Ptr 120 (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); 121 122 -- Ignore if length is not 2 123 124 if Env_Value_Length /= 2 then 125 C1 := 'I'; 126 C2 := 'N'; 127 128 -- Length is 2, see if it is a valid value 129 130 else 131 -- Acquire two characters and fold to upper case 132 133 C1 := Env_Value_Ptr (1); 134 C2 := Env_Value_Ptr (2); 135 136 if C1 in 'a' .. 'z' then 137 C1 := Character'Val (Character'Pos (C1) - 32); 138 end if; 139 140 if C2 in 'a' .. 'z' then 141 C2 := Character'Val (Character'Pos (C2) - 32); 142 end if; 143 144 -- IN/LO/HI are ok values 145 146 if (C1 = 'I' and then C2 = 'N') 147 or else 148 (C1 = 'L' and then C2 = 'O') 149 or else 150 (C1 = 'H' and then C2 = 'I') 151 then 152 null; 153 154 -- Try for valid hex digits 155 156 elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z') 157 or else 158 (C2 in '0' .. '9' or else C2 in 'A' .. 'Z') 159 then 160 null; 161 162 -- Otherwise environment value is bad, ignore and use IN (invalid) 163 164 else 165 C1 := 'I'; 166 C2 := 'N'; 167 end if; 168 end if; 169 end if; 170 171 -- IN (invalid value) 172 173 if C1 = 'I' and then C2 = 'N' then 174 IS_Is1 := 16#80#; 175 IS_Is2 := 16#8000#; 176 IS_Is4 := 16#8000_0000#; 177 IS_Is8 := 16#8000_0000_0000_0000#; 178 IS_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#; 179 180 IS_Iu1 := 16#FF#; 181 IS_Iu2 := 16#FFFF#; 182 IS_Iu4 := 16#FFFF_FFFF#; 183 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 184 IS_Iu16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; 185 186 IS_Iz1 := 16#00#; 187 IS_Iz2 := 16#0000#; 188 IS_Iz4 := 16#0000_0000#; 189 IS_Iz8 := 16#0000_0000_0000_0000#; 190 IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; 191 192 if AFloat then 193 IV_Isf := 16#FFFF_FF00#; 194 IV_Ifl := 16#FFFF_FF00#; 195 IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); 196 197 else 198 IV_Isf := IS_Iu4; 199 IV_Ifl := IS_Iu4; 200 IV_Ilf := To_ByteLF (IS_Iu8); 201 end if; 202 203 if EFloat then 204 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); 205 end if; 206 207 -- LO (Low values) 208 209 elsif C1 = 'L' and then C2 = 'O' then 210 IS_Is1 := 16#80#; 211 IS_Is2 := 16#8000#; 212 IS_Is4 := 16#8000_0000#; 213 IS_Is8 := 16#8000_0000_0000_0000#; 214 IS_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#; 215 216 IS_Iu1 := 16#00#; 217 IS_Iu2 := 16#0000#; 218 IS_Iu4 := 16#0000_0000#; 219 IS_Iu8 := 16#0000_0000_0000_0000#; 220 IS_Iu16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; 221 222 IS_Iz1 := 16#00#; 223 IS_Iz2 := 16#0000#; 224 IS_Iz4 := 16#0000_0000#; 225 IS_Iz8 := 16#0000_0000_0000_0000#; 226 IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; 227 228 if AFloat then 229 IV_Isf := 16#0000_0001#; 230 IV_Ifl := 16#0000_0001#; 231 IV_Ilf := (1, 0, 0, 0, 0, 0); 232 233 else 234 IV_Isf := 16#FF80_0000#; 235 IV_Ifl := 16#FF80_0000#; 236 IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); 237 end if; 238 239 if EFloat then 240 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); 241 end if; 242 243 -- HI (High values) 244 245 elsif C1 = 'H' and then C2 = 'I' then 246 IS_Is1 := 16#7F#; 247 IS_Is2 := 16#7FFF#; 248 IS_Is4 := 16#7FFF_FFFF#; 249 IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; 250 IS_Is16 := 16#7FFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; 251 252 IS_Iu1 := 16#FF#; 253 IS_Iu2 := 16#FFFF#; 254 IS_Iu4 := 16#FFFF_FFFF#; 255 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 256 IS_Iu16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; 257 258 IS_Iz1 := 16#FF#; 259 IS_Iz2 := 16#FFFF#; 260 IS_Iz4 := 16#FFFF_FFFF#; 261 IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#; 262 IS_Iz16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; 263 264 if AFloat then 265 IV_Isf := 16#7FFF_FFFF#; 266 IV_Ifl := 16#7FFF_FFFF#; 267 IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); 268 269 else 270 IV_Isf := 16#7F80_0000#; 271 IV_Ifl := 16#7F80_0000#; 272 IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); 273 end if; 274 275 if EFloat then 276 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); 277 end if; 278 279 -- -Shh (hex byte) 280 281 else 282 -- Convert the two hex digits (we know they are valid here) 283 284 B := 16 * (Character'Pos (C1) 285 - (if C1 in '0' .. '9' 286 then Character'Pos ('0') 287 else Character'Pos ('A') - 10)) 288 + (Character'Pos (C2) 289 - (if C2 in '0' .. '9' 290 then Character'Pos ('0') 291 else Character'Pos ('A') - 10)); 292 293 -- Initialize data values from the hex value 294 295 IS_Is1 := B; 296 IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); 297 IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); 298 IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); 299 IS_Is16 := 2**64 * Byte16 (IS_Is8) + Byte16 (IS_Is8); 300 301 IS_Iu1 := IS_Is1; 302 IS_Iu2 := IS_Is2; 303 IS_Iu4 := IS_Is4; 304 IS_Iu8 := IS_Is8; 305 IS_Iu16 := IS_Is16; 306 307 IS_Iz1 := IS_Is1; 308 IS_Iz2 := IS_Is2; 309 IS_Iz4 := IS_Is4; 310 IS_Iz8 := IS_Is8; 311 IS_Iz16 := IS_Is16; 312 313 IV_Isf := IS_Is4; 314 IV_Ifl := IS_Is4; 315 316 if AFloat then 317 IV_Ill := (B, B, B, B, B, B); 318 else 319 IV_Ilf := To_ByteLF (IS_Is8); 320 end if; 321 322 if EFloat then 323 IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); 324 end if; 325 end if; 326 327 -- If no separate Long_Long_Float, then use Long_Float value as 328 -- Long_Long_Float initial value. 329 330 if not EFloat then 331 declare 332 pragma Warnings (Off); -- why??? 333 function To_ByteLLF is 334 new Ada.Unchecked_Conversion (ByteLF, ByteLLF); 335 pragma Warnings (On); 336 begin 337 IV_Ill := To_ByteLLF (IV_Ilf); 338 end; 339 end if; 340 end Initialize; 341 342end System.Scalar_Values; 343