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 179 IS_Iu1 := 16#FF#; 180 IS_Iu2 := 16#FFFF#; 181 IS_Iu4 := 16#FFFF_FFFF#; 182 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 183 184 IS_Iz1 := 16#00#; 185 IS_Iz2 := 16#0000#; 186 IS_Iz4 := 16#0000_0000#; 187 IS_Iz8 := 16#0000_0000_0000_0000#; 188 189 if AFloat then 190 IV_Isf := 16#FFFF_FF00#; 191 IV_Ifl := 16#FFFF_FF00#; 192 IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); 193 194 else 195 IV_Isf := IS_Iu4; 196 IV_Ifl := IS_Iu4; 197 IV_Ilf := To_ByteLF (IS_Iu8); 198 end if; 199 200 if EFloat then 201 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); 202 end if; 203 204 -- LO (Low values) 205 206 elsif C1 = 'L' and then C2 = 'O' then 207 IS_Is1 := 16#80#; 208 IS_Is2 := 16#8000#; 209 IS_Is4 := 16#8000_0000#; 210 IS_Is8 := 16#8000_0000_0000_0000#; 211 212 IS_Iu1 := 16#00#; 213 IS_Iu2 := 16#0000#; 214 IS_Iu4 := 16#0000_0000#; 215 IS_Iu8 := 16#0000_0000_0000_0000#; 216 217 IS_Iz1 := 16#00#; 218 IS_Iz2 := 16#0000#; 219 IS_Iz4 := 16#0000_0000#; 220 IS_Iz8 := 16#0000_0000_0000_0000#; 221 222 if AFloat then 223 IV_Isf := 16#0000_0001#; 224 IV_Ifl := 16#0000_0001#; 225 IV_Ilf := (1, 0, 0, 0, 0, 0); 226 227 else 228 IV_Isf := 16#FF80_0000#; 229 IV_Ifl := 16#FF80_0000#; 230 IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); 231 end if; 232 233 if EFloat then 234 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); 235 end if; 236 237 -- HI (High values) 238 239 elsif C1 = 'H' and then C2 = 'I' then 240 IS_Is1 := 16#7F#; 241 IS_Is2 := 16#7FFF#; 242 IS_Is4 := 16#7FFF_FFFF#; 243 IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; 244 245 IS_Iu1 := 16#FF#; 246 IS_Iu2 := 16#FFFF#; 247 IS_Iu4 := 16#FFFF_FFFF#; 248 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 249 250 IS_Iz1 := 16#FF#; 251 IS_Iz2 := 16#FFFF#; 252 IS_Iz4 := 16#FFFF_FFFF#; 253 IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#; 254 255 if AFloat then 256 IV_Isf := 16#7FFF_FFFF#; 257 IV_Ifl := 16#7FFF_FFFF#; 258 IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); 259 260 else 261 IV_Isf := 16#7F80_0000#; 262 IV_Ifl := 16#7F80_0000#; 263 IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); 264 end if; 265 266 if EFloat then 267 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); 268 end if; 269 270 -- -Shh (hex byte) 271 272 else 273 -- Convert the two hex digits (we know they are valid here) 274 275 B := 16 * (Character'Pos (C1) 276 - (if C1 in '0' .. '9' 277 then Character'Pos ('0') 278 else Character'Pos ('A') - 10)) 279 + (Character'Pos (C2) 280 - (if C2 in '0' .. '9' 281 then Character'Pos ('0') 282 else Character'Pos ('A') - 10)); 283 284 -- Initialize data values from the hex value 285 286 IS_Is1 := B; 287 IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); 288 IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); 289 IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); 290 291 IS_Iu1 := IS_Is1; 292 IS_Iu2 := IS_Is2; 293 IS_Iu4 := IS_Is4; 294 IS_Iu8 := IS_Is8; 295 296 IS_Iz1 := IS_Is1; 297 IS_Iz2 := IS_Is2; 298 IS_Iz4 := IS_Is4; 299 IS_Iz8 := IS_Is8; 300 301 IV_Isf := IS_Is4; 302 IV_Ifl := IS_Is4; 303 304 if AFloat then 305 IV_Ill := (B, B, B, B, B, B); 306 else 307 IV_Ilf := To_ByteLF (IS_Is8); 308 end if; 309 310 if EFloat then 311 IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); 312 end if; 313 end if; 314 315 -- If no separate Long_Long_Float, then use Long_Float value as 316 -- Long_Long_Float initial value. 317 318 if not EFloat then 319 declare 320 pragma Warnings (Off); -- why??? 321 function To_ByteLLF is 322 new Ada.Unchecked_Conversion (ByteLF, ByteLLF); 323 pragma Warnings (On); 324 begin 325 IV_Ill := To_ByteLLF (IV_Ilf); 326 end; 327 end if; 328 end Initialize; 329 330end System.Scalar_Values; 331