1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUNTIME 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 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Unchecked_Conversion; 35 36package body System.Scalar_Values is 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_get_env_value_ptr"); 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 type ByteLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1; 64 -- Type used to initialize Long_Long_Float values used on x86 and 65 -- any other target with the same 80-bit floating-point values that 66 -- GCC always stores in 96-bits. Note that we are assuming Intel 67 -- format little-endian addressing for this type. On non-Intel 68 -- architectures, this is the same length as Byte8 and holds 69 -- a Long_Float value. 70 71 -- The following variables are used to initialize the float values 72 -- by overlay. We can't assign directly to the float values, since 73 -- we may be assigning signalling Nan's that will cause a trap if 74 -- loaded into a floating-point register. 75 76 IV_Isf : aliased Byte4; -- Initialize short float 77 IV_Ifl : aliased Byte4; -- Initialize float 78 IV_Ilf : aliased Byte8; -- Initialize long float 79 IV_Ill : aliased ByteLF; -- Initialize long long float 80 81 for IV_Isf'Address use IS_Isf'Address; 82 for IV_Ifl'Address use IS_Ifl'Address; 83 for IV_Ilf'Address use IS_Ilf'Address; 84 for IV_Ill'Address use IS_Ill'Address; 85 86 -- The following pragmas are used to suppress initialization 87 88 pragma Import (Ada, IV_Isf); 89 pragma Import (Ada, IV_Ifl); 90 pragma Import (Ada, IV_Ilf); 91 pragma Import (Ada, IV_Ill); 92 93 begin 94 -- Acquire environment variable value if necessary 95 96 if C1 = 'E' and then C2 = 'V' then 97 Get_Env_Value_Ptr 98 (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); 99 100 -- Ignore if length is not 2 101 102 if Env_Value_Length /= 2 then 103 C1 := 'I'; 104 C2 := 'N'; 105 106 -- Length is 2, see if it is a valid value 107 108 else 109 -- Acquire two characters and fold to upper case 110 111 C1 := Env_Value_Ptr (1); 112 C2 := Env_Value_Ptr (2); 113 114 if C1 in 'a' .. 'z' then 115 C1 := Character'Val (Character'Pos (C1) - 32); 116 end if; 117 118 if C2 in 'a' .. 'z' then 119 C2 := Character'Val (Character'Pos (C2) - 32); 120 end if; 121 122 -- IN/LO/HI are ok values 123 124 if (C1 = 'I' and then C2 = 'N') 125 or else 126 (C1 = 'L' and then C2 = 'O') 127 or else 128 (C1 = 'H' and then C2 = 'I') 129 then 130 null; 131 132 -- Try for valid hex digits 133 134 elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z') 135 or else 136 (C2 in '0' .. '9' or else C2 in 'A' .. 'Z') 137 then 138 null; 139 140 -- Otherwise environment value is bad, ignore and use IN (invalid) 141 142 else 143 C1 := 'I'; 144 C2 := 'N'; 145 end if; 146 end if; 147 end if; 148 149 -- IN (invalid value) 150 151 if C1 = 'I' and then C2 = 'N' then 152 IS_Is1 := 16#80#; 153 IS_Is2 := 16#8000#; 154 IS_Is4 := 16#8000_0000#; 155 IS_Is8 := 16#8000_0000_0000_0000#; 156 157 IS_Iu1 := 16#FF#; 158 IS_Iu2 := 16#FFFF#; 159 IS_Iu4 := 16#FFFF_FFFF#; 160 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 161 162 IV_Isf := IS_Iu4; 163 IV_Ifl := IS_Iu4; 164 IV_Ilf := IS_Iu8; 165 166 if EFloat then 167 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); 168 end if; 169 170 -- LO (Low values) 171 172 elsif C1 = 'L' and then C2 = 'O' then 173 IS_Is1 := 16#80#; 174 IS_Is2 := 16#8000#; 175 IS_Is4 := 16#8000_0000#; 176 IS_Is8 := 16#8000_0000_0000_0000#; 177 178 IS_Iu1 := 16#00#; 179 IS_Iu2 := 16#0000#; 180 IS_Iu4 := 16#0000_0000#; 181 IS_Iu8 := 16#0000_0000_0000_0000#; 182 183 IV_Isf := 16#FF80_0000#; 184 IV_Ifl := 16#FF80_0000#; 185 IV_Ilf := 16#FFF0_0000_0000_0000#; 186 187 if EFloat then 188 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); 189 end if; 190 191 -- HI (High values) 192 193 elsif C1 = 'H' and then C2 = 'I' then 194 IS_Is1 := 16#7F#; 195 IS_Is2 := 16#7FFF#; 196 IS_Is4 := 16#7FFF_FFFF#; 197 IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; 198 199 IS_Iu1 := 16#FF#; 200 IS_Iu2 := 16#FFFF#; 201 IS_Iu4 := 16#FFFF_FFFF#; 202 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; 203 204 IV_Isf := 16#7F80_0000#; 205 IV_Ifl := 16#7F80_0000#; 206 IV_Ilf := 16#7FF0_0000_0000_0000#; 207 208 if EFloat then 209 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); 210 end if; 211 212 -- -Shh (hex byte) 213 214 else 215 -- Convert the two hex digits (we know they are valid here) 216 217 if C1 in '0' .. '9' then 218 B := Character'Pos (C1) - Character'Pos ('0'); 219 else 220 B := Character'Pos (C1) - (Character'Pos ('A') - 10); 221 end if; 222 223 if C2 in '0' .. '9' then 224 B := B * 16 + Character'Pos (C2) - Character'Pos ('0'); 225 else 226 B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10); 227 end if; 228 229 -- Initialize data values from the hex value 230 231 IS_Is1 := B; 232 IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); 233 IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); 234 IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); 235 236 IS_Iu1 := IS_Is1; 237 IS_Iu2 := IS_Is2; 238 IS_Iu4 := IS_Is4; 239 IS_Iu8 := IS_Is8; 240 241 IV_Isf := IS_Is4; 242 IV_Ifl := IS_Is4; 243 IV_Ilf := IS_Is8; 244 245 if EFloat then 246 IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); 247 end if; 248 end if; 249 250 -- If no separate Long_Long_Float, then use Long_Float value as 251 -- Long_Long_Float initial value. 252 253 if not EFloat then 254 declare 255 pragma Warnings (Off); 256 function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF); 257 pragma Warnings (On); 258 begin 259 IV_Ill := To_ByteLF (IV_Ilf); 260 end; 261 end if; 262 263 264 end Initialize; 265 266end System.Scalar_Values; 267