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