1------------------------------------------------------------------------------ 2-- -- 3-- GNAAMP COMPILER COMPONENTS -- 4-- -- 5-- A A _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2012, AdaCore -- 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. 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21------------------------------------------------------------------------------ 22 23with Sem_Aux; use Sem_Aux; 24with Sinput; use Sinput; 25with Stand; use Stand; 26with Stringt; use Stringt; 27 28with GNAT.Case_Util; use GNAT.Case_Util; 29 30package body AA_Util is 31 32 ---------------------- 33 -- Is_Global_Entity -- 34 ---------------------- 35 36 function Is_Global_Entity (E : Entity_Id) return Boolean is 37 begin 38 return Enclosing_Dynamic_Scope (E) = Standard_Standard; 39 end Is_Global_Entity; 40 41 ----------------- 42 -- New_Name_Id -- 43 ----------------- 44 45 function New_Name_Id (Name : String) return Name_Id is 46 begin 47 for J in 1 .. Name'Length loop 48 Name_Buffer (J) := Name (Name'First + (J - 1)); 49 end loop; 50 51 Name_Len := Name'Length; 52 return Name_Find; 53 end New_Name_Id; 54 55 ----------------- 56 -- Name_String -- 57 ----------------- 58 59 function Name_String (Name : Name_Id) return String is 60 begin 61 pragma Assert (Name /= No_Name); 62 return Get_Name_String (Name); 63 end Name_String; 64 65 ------------------- 66 -- New_String_Id -- 67 ------------------- 68 69 function New_String_Id (S : String) return String_Id is 70 begin 71 for J in 1 .. S'Length loop 72 Name_Buffer (J) := S (S'First + (J - 1)); 73 end loop; 74 75 Name_Len := S'Length; 76 return String_From_Name_Buffer; 77 end New_String_Id; 78 79 ------------------ 80 -- String_Value -- 81 ------------------ 82 83 function String_Value (Str_Id : String_Id) return String is 84 begin 85 -- ??? pragma Assert (Str_Id /= No_String); 86 87 if Str_Id = No_String then 88 return ""; 89 end if; 90 91 String_To_Name_Buffer (Str_Id); 92 93 return Name_Buffer (1 .. Name_Len); 94 end String_Value; 95 96 --------------- 97 -- Next_Name -- 98 --------------- 99 100 function Next_Name 101 (Name_Seq : not null access Name_Sequencer; 102 Name_Prefix : String) return Name_Id 103 is 104 begin 105 Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1; 106 107 declare 108 Number_Image : constant String := Name_Seq.Sequence_Number'Img; 109 begin 110 return New_Name_Id 111 (Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last)); 112 end; 113 end Next_Name; 114 115 -------------------- 116 -- Elab_Spec_Name -- 117 -------------------- 118 119 function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is 120 begin 121 return New_Name_Id (Name_String (Module_Name) & "___elabs"); 122 end Elab_Spec_Name; 123 124 -------------------- 125 -- Elab_Spec_Name -- 126 -------------------- 127 128 function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is 129 begin 130 return New_Name_Id (Name_String (Module_Name) & "___elabb"); 131 end Elab_Body_Name; 132 133 -------------------------------- 134 -- Source_Name_Without_Suffix -- 135 -------------------------------- 136 137 function File_Name_Without_Suffix (File_Name : String) return String is 138 Name_Index : Natural := File_Name'Last; 139 140 begin 141 pragma Assert (File_Name'Length > 0); 142 143 -- We loop in reverse to ensure that file names that follow nonstandard 144 -- naming conventions that include additional dots are handled properly, 145 -- preserving dots in front of the main file suffix (for example, 146 -- main.2.ada => main.2). 147 148 while Name_Index >= File_Name'First 149 and then File_Name (Name_Index) /= '.' 150 loop 151 Name_Index := Name_Index - 1; 152 end loop; 153 154 -- Return the part of the file name up to but not including the last dot 155 -- in the name, or return the whole name as is if no dot character was 156 -- found. 157 158 if Name_Index >= File_Name'First then 159 return File_Name (File_Name'First .. Name_Index - 1); 160 161 else 162 return File_Name; 163 end if; 164 end File_Name_Without_Suffix; 165 166 ----------------- 167 -- Source_Name -- 168 ----------------- 169 170 function Source_Name (Sloc : Source_Ptr) return File_Name_Type is 171 begin 172 if Sloc = No_Location or Sloc = Standard_Location then 173 return No_File; 174 else 175 return File_Name (Get_Source_File_Index (Sloc)); 176 end if; 177 end Source_Name; 178 179 -------------------------------- 180 -- Source_Name_Without_Suffix -- 181 -------------------------------- 182 183 function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is 184 Src_Name : constant String := 185 Name_String (Name_Id (Source_Name (Sloc))); 186 Src_Index : Natural := Src_Name'Last; 187 188 begin 189 pragma Assert (Src_Name'Length > 0); 190 191 -- Treat the presence of a ".dg" suffix specially, stripping it off 192 -- in addition to any suffix preceding it. 193 194 if Src_Name'Length >= 4 195 and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg" 196 then 197 Src_Index := Src_Index - 3; 198 end if; 199 200 return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index)); 201 end Source_Name_Without_Suffix; 202 203 ---------------------- 204 -- Source_Id_String -- 205 ---------------------- 206 207 function Source_Id_String (Unit_Name : Name_Id) return String is 208 Unit_String : String := Name_String (Unit_Name); 209 Name_Last : Positive := Unit_String'Last; 210 Name_Index : Positive := Unit_String'First; 211 212 begin 213 To_Mixed (Unit_String); 214 215 -- Replace any embedded sequences of two or more '_' characters 216 -- with a single '.' character. Note that this will leave any 217 -- leading or trailing single '_' characters untouched, but those 218 -- should normally not occur in compilation unit names (and if 219 -- they do then it's better to leave them as is). 220 221 while Name_Index <= Name_Last loop 222 if Unit_String (Name_Index) = '_' 223 and then Name_Index /= Name_Last 224 and then Unit_String (Name_Index + 1) = '_' 225 then 226 Unit_String (Name_Index) := '.'; 227 Name_Index := Name_Index + 1; 228 229 while Unit_String (Name_Index) = '_' 230 and then Name_Index <= Name_Last 231 loop 232 Unit_String (Name_Index .. Name_Last - 1) 233 := Unit_String (Name_Index + 1 .. Name_Last); 234 Name_Last := Name_Last - 1; 235 end loop; 236 237 else 238 Name_Index := Name_Index + 1; 239 end if; 240 end loop; 241 242 return Unit_String (Unit_String'First .. Name_Last); 243 end Source_Id_String; 244 245 -- This version of Source_Id_String is obsolescent and is being 246 -- replaced with the above function. 247 248 function Source_Id_String (Sloc : Source_Ptr) return String is 249 File_Index : Source_File_Index; 250 251 begin 252 -- Use an arbitrary artificial 22-character value for package Standard, 253 -- since Standard doesn't have an associated source file. 254 255 if Sloc <= Standard_Location then 256 return "20010101010101standard"; 257 258 -- Return the concatentation of the source file's timestamp and 259 -- its 8-digit hex checksum. 260 261 else 262 File_Index := Get_Source_File_Index (Sloc); 263 264 return String (Time_Stamp (File_Index)) 265 & Get_Hex_String (Source_Checksum (File_Index)); 266 end if; 267 end Source_Id_String; 268 269 --------------- 270 -- Source_Id -- 271 --------------- 272 273 function Source_Id (Unit_Name : Name_Id) return String_Id is 274 begin 275 return New_String_Id (Source_Id_String (Unit_Name)); 276 end Source_Id; 277 278 -- This version of Source_Id is obsolescent and is being 279 -- replaced with the above function. 280 281 function Source_Id (Sloc : Source_Ptr) return String_Id is 282 begin 283 return New_String_Id (Source_Id_String (Sloc)); 284 end Source_Id; 285 286 ----------- 287 -- Image -- 288 ----------- 289 290 function Image (I : Int) return String is 291 Image_String : constant String := Pos'Image (I); 292 begin 293 if Image_String (1) = ' ' then 294 return Image_String (2 .. Image_String'Last); 295 else 296 return Image_String; 297 end if; 298 end Image; 299 300 -------------- 301 -- UI_Image -- 302 -------------- 303 304 function UI_Image (I : Uint; Format : Integer_Image_Format) return String is 305 begin 306 if Format = Decimal then 307 UI_Image (I, Format => Decimal); 308 return UI_Image_Buffer (1 .. UI_Image_Length); 309 310 elsif Format = Ada_Hex then 311 UI_Image (I, Format => Hex); 312 return UI_Image_Buffer (1 .. UI_Image_Length); 313 314 else 315 pragma Assert (I >= Uint_0); 316 317 UI_Image (I, Format => Hex); 318 319 pragma Assert (UI_Image_Buffer (1 .. 3) = "16#" 320 and then UI_Image_Buffer (UI_Image_Length) = '#'); 321 322 -- Declare a string where we will copy the digits from the UI_Image, 323 -- interspersing '_' characters as 4-digit group separators. The 324 -- underscores in UI_Image's result are not always at the places 325 -- where we want them, which is why we do the following copy 326 -- (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^"). 327 328 declare 329 Hex_String : String (1 .. UI_Image_Max); 330 Last_Index : Natural; 331 Digit_Count : Natural := 0; 332 UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket 333 Sep_Count : Natural := 0; 334 335 begin 336 -- Count up the number of non-underscore characters in the 337 -- literal value portion of the UI_Image string. 338 339 while UI_Image_Buffer (UI_Image_Index) /= '#' loop 340 if UI_Image_Buffer (UI_Image_Index) /= '_' then 341 Digit_Count := Digit_Count + 1; 342 end if; 343 344 UI_Image_Index := UI_Image_Index + 1; 345 end loop; 346 347 UI_Image_Index := 4; -- Reset the index past the "16#" bracket 348 349 Last_Index := 1; 350 351 Hex_String (Last_Index) := '^'; 352 Last_Index := Last_Index + 1; 353 354 -- Copy digits from UI_Image_Buffer to Hex_String, adding 355 -- underscore separators as appropriate. The initial value 356 -- of Sep_Count accounts for the leading '^' and being one 357 -- character ahead after inserting a digit. 358 359 Sep_Count := 2; 360 361 while UI_Image_Buffer (UI_Image_Index) /= '#' loop 362 if UI_Image_Buffer (UI_Image_Index) /= '_' then 363 Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index); 364 365 Last_Index := Last_Index + 1; 366 367 -- Add '_' characters to separate groups of four hex 368 -- digits for readability (grouping from right to left). 369 370 if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then 371 Hex_String (Last_Index) := '_'; 372 Last_Index := Last_Index + 1; 373 Sep_Count := Sep_Count + 1; 374 end if; 375 end if; 376 377 UI_Image_Index := UI_Image_Index + 1; 378 end loop; 379 380 -- Back up before any trailing underscore 381 382 if Hex_String (Last_Index - 1) = '_' then 383 Last_Index := Last_Index - 1; 384 end if; 385 386 Hex_String (Last_Index) := '^'; 387 388 return Hex_String (1 .. Last_Index); 389 end; 390 end if; 391 end UI_Image; 392 393 -------------- 394 -- UR_Image -- 395 -------------- 396 397 -- Shouldn't this be added to Urealp??? 398 399 function UR_Image (R : Ureal) return String is 400 401 -- The algorithm used here for conversion of Ureal values 402 -- is taken from the JGNAT back end. 403 404 Num : Long_Long_Float := 0.0; 405 Den : Long_Long_Float := 0.0; 406 Sign : Long_Long_Float := 1.0; 407 Result : Long_Long_Float; 408 Tmp : Uint; 409 Index : Integer; 410 411 begin 412 if UR_Is_Negative (R) then 413 Sign := -1.0; 414 end if; 415 416 -- In the following calculus, we consider numbers modulo 2 ** 31, 417 -- so that we don't have problems with signed Int... 418 419 Tmp := abs (Numerator (R)); 420 Index := 0; 421 while Tmp > 0 loop 422 Num := Num 423 + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31))) 424 * (2.0 ** Index); 425 Tmp := Tmp / Uint_2 ** 31; 426 Index := Index + 31; 427 end loop; 428 429 Tmp := abs (Denominator (R)); 430 if Rbase (R) /= 0 then 431 Tmp := Rbase (R) ** Tmp; 432 end if; 433 434 Index := 0; 435 while Tmp > 0 loop 436 Den := Den 437 + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31))) 438 * (2.0 ** Index); 439 Tmp := Tmp / Uint_2 ** 31; 440 Index := Index + 31; 441 end loop; 442 443 -- If the denominator denotes a negative power of Rbase, 444 -- then multiply by the denominator. 445 446 if Rbase (R) /= 0 and then Denominator (R) < 0 then 447 Result := Sign * Num * Den; 448 449 -- Otherwise compute the quotient 450 451 else 452 Result := Sign * Num / Den; 453 end if; 454 455 return Long_Long_Float'Image (Result); 456 end UR_Image; 457 458end AA_Util; 459