1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G E T _ S C O S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2009-2019, 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. 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-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Ada_2005; 27-- This unit is not part of the compiler proper, it is used in tools that 28-- read SCO information from ALI files (Xcov and sco_test). Ada 2005 29-- constructs may therefore be used freely (and are indeed). 30 31with Namet; use Namet; 32with SCOs; use SCOs; 33with Types; use Types; 34 35with Ada.IO_Exceptions; use Ada.IO_Exceptions; 36 37procedure Get_SCOs is 38 Dnum : Nat; 39 C : Character; 40 Loc1 : Source_Location; 41 Loc2 : Source_Location; 42 Cond : Character; 43 Dtyp : Character; 44 45 use ASCII; 46 -- For CR/LF 47 48 function At_EOL return Boolean; 49 -- Skips any spaces, then checks if we are the end of a line. If so, 50 -- returns True (but does not skip over the EOL sequence). If not, 51 -- then returns False. 52 53 procedure Check (C : Character); 54 -- Checks that file is positioned at given character, and if so skips past 55 -- it, If not, raises Data_Error. 56 57 function Get_Int return Int; 58 -- On entry the file is positioned to a digit. On return, the file is 59 -- positioned past the last digit, and the returned result is the decimal 60 -- value read. Data_Error is raised for overflow (value greater than 61 -- Int'Last), or if the initial character is not a digit. 62 63 procedure Get_Source_Location (Loc : out Source_Location); 64 -- Reads a source location in the form line:col and places the source 65 -- location in Loc. Raises Data_Error if the format does not match this 66 -- requirement. Note that initial spaces are not skipped. 67 68 procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location); 69 -- Skips initial spaces, then reads a source location range in the form 70 -- line:col-line:col and places the two source locations in Loc1 and Loc2. 71 -- Raises Data_Error if format does not match this requirement. 72 73 procedure Skip_EOL; 74 -- Called with the current character about to be read being LF or CR. Skips 75 -- past CR/LF characters until either a non-CR/LF character is found, or 76 -- the end of file is encountered. 77 78 procedure Skip_Spaces; 79 -- Skips zero or more spaces at the current position, leaving the file 80 -- positioned at the first non-blank character (or Types.EOF). 81 82 ------------ 83 -- At_EOL -- 84 ------------ 85 86 function At_EOL return Boolean is 87 begin 88 Skip_Spaces; 89 return Nextc = CR or else Nextc = LF; 90 end At_EOL; 91 92 ----------- 93 -- Check -- 94 ----------- 95 96 procedure Check (C : Character) is 97 begin 98 if Nextc = C then 99 Skipc; 100 else 101 raise Data_Error; 102 end if; 103 end Check; 104 105 ------------- 106 -- Get_Int -- 107 ------------- 108 109 function Get_Int return Int is 110 Val : Int; 111 C : Character; 112 113 begin 114 C := Nextc; 115 Val := 0; 116 117 if C not in '0' .. '9' then 118 raise Data_Error; 119 end if; 120 121 -- Loop to read digits of integer value 122 123 loop 124 declare 125 pragma Unsuppress (Overflow_Check); 126 begin 127 Val := Val * 10 + (Character'Pos (C) - Character'Pos ('0')); 128 end; 129 130 Skipc; 131 C := Nextc; 132 133 exit when C not in '0' .. '9'; 134 end loop; 135 136 return Val; 137 138 exception 139 when Constraint_Error => 140 raise Data_Error; 141 end Get_Int; 142 143 ------------------------- 144 -- Get_Source_Location -- 145 ------------------------- 146 147 procedure Get_Source_Location (Loc : out Source_Location) is 148 pragma Unsuppress (Range_Check); 149 begin 150 Loc.Line := Logical_Line_Number (Get_Int); 151 Check (':'); 152 Loc.Col := Column_Number (Get_Int); 153 exception 154 when Constraint_Error => 155 raise Data_Error; 156 end Get_Source_Location; 157 158 ------------------------------- 159 -- Get_Source_Location_Range -- 160 ------------------------------- 161 162 procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is 163 begin 164 Skip_Spaces; 165 Get_Source_Location (Loc1); 166 Check ('-'); 167 Get_Source_Location (Loc2); 168 end Get_Source_Location_Range; 169 170 -------------- 171 -- Skip_EOL -- 172 -------------- 173 174 procedure Skip_EOL is 175 C : Character; 176 177 begin 178 loop 179 Skipc; 180 C := Nextc; 181 exit when C /= LF and then C /= CR; 182 end loop; 183 end Skip_EOL; 184 185 ----------------- 186 -- Skip_Spaces -- 187 ----------------- 188 189 procedure Skip_Spaces is 190 begin 191 while Nextc = ' ' loop 192 Skipc; 193 end loop; 194 end Skip_Spaces; 195 196 Buf : String (1 .. 32_768); 197 N : Natural; 198 -- Scratch buffer, and index into it 199 200 Nam : Name_Id; 201 202-- Start of processing for Get_SCOs 203 204begin 205 SCOs.Initialize; 206 207 -- Loop through lines of SCO information 208 209 while Nextc = 'C' loop 210 Skipc; 211 212 C := Getc; 213 214 -- Make sure first line is a header line 215 216 if SCO_Unit_Table.Last = 0 and then C /= ' ' then 217 raise Data_Error; 218 end if; 219 220 -- Otherwise dispatch on type of line 221 222 case C is 223 224 -- Header or instance table entry 225 226 when ' ' => 227 228 -- Complete previous entry if any 229 230 if SCO_Unit_Table.Last /= 0 then 231 SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := 232 SCO_Table.Last; 233 end if; 234 235 Skip_Spaces; 236 237 case Nextc is 238 239 -- Instance table entry 240 241 when 'i' => 242 declare 243 Inum : SCO_Instance_Index; 244 begin 245 Skipc; 246 Skip_Spaces; 247 248 Inum := SCO_Instance_Index (Get_Int); 249 SCO_Instance_Table.Increment_Last; 250 pragma Assert (SCO_Instance_Table.Last = Inum); 251 252 Skip_Spaces; 253 declare 254 SIE : SCO_Instance_Table_Entry 255 renames SCO_Instance_Table.Table (Inum); 256 begin 257 SIE.Inst_Dep_Num := Get_Int; 258 C := Getc; 259 pragma Assert (C = '|'); 260 Get_Source_Location (SIE.Inst_Loc); 261 262 if At_EOL then 263 SIE.Enclosing_Instance := 0; 264 else 265 Skip_Spaces; 266 SIE.Enclosing_Instance := 267 SCO_Instance_Index (Get_Int); 268 pragma Assert (SIE.Enclosing_Instance in 269 SCO_Instance_Table.First 270 .. SCO_Instance_Table.Last); 271 end if; 272 end; 273 end; 274 275 -- Unit header 276 277 when '0' .. '9' => 278 -- Scan out dependency number and file name 279 280 Dnum := Get_Int; 281 282 Skip_Spaces; 283 284 N := 0; 285 while Nextc > ' ' loop 286 N := N + 1; 287 Buf (N) := Getc; 288 end loop; 289 290 -- Make new unit table entry (will fill in To later) 291 292 SCO_Unit_Table.Append ( 293 (File_Name => new String'(Buf (1 .. N)), 294 File_Index => 0, 295 Dep_Num => Dnum, 296 From => SCO_Table.Last + 1, 297 To => 0)); 298 299 when others => 300 raise Program_Error; 301 end case; 302 303 -- Statement entry 304 305 when 'S' | 's' => 306 declare 307 Typ : Character; 308 Key : Character; 309 310 begin 311 Key := 'S'; 312 313 -- If continuation, reset Last indication in last entry stored 314 -- for previous CS or cs line. 315 316 if C = 's' then 317 SCO_Table.Table (SCO_Table.Last).Last := False; 318 end if; 319 320 -- Initialize to scan items on one line 321 322 Skip_Spaces; 323 324 -- Loop through items on one line 325 326 loop 327 Nam := No_Name; 328 Typ := Nextc; 329 330 case Typ is 331 when '>' => 332 333 -- Dominance marker may be present only at entry point 334 335 pragma Assert (Key = 'S'); 336 337 Skipc; 338 Key := '>'; 339 Typ := Getc; 340 341 -- Sanity check on dominance marker type indication 342 343 pragma Assert (Typ in 'A' .. 'Z'); 344 345 when '1' .. '9' => 346 Typ := ' '; 347 348 when others => 349 Skipc; 350 if Typ = 'P' or else Typ = 'p' then 351 if Nextc not in '1' .. '9' then 352 Name_Len := 0; 353 loop 354 Name_Len := Name_Len + 1; 355 Name_Buffer (Name_Len) := Getc; 356 exit when Nextc = ':'; 357 end loop; 358 359 Skipc; -- Past ':' 360 361 Nam := Name_Find; 362 end if; 363 end if; 364 end case; 365 366 if Key = '>' and then Typ /= 'E' then 367 Get_Source_Location (Loc1); 368 Loc2 := No_Source_Location; 369 else 370 Get_Source_Location_Range (Loc1, Loc2); 371 end if; 372 373 SCO_Table.Append 374 ((C1 => Key, 375 C2 => Typ, 376 From => Loc1, 377 To => Loc2, 378 Last => At_EOL, 379 Pragma_Sloc => No_Location, 380 Pragma_Aspect_Name => Nam)); 381 382 if Key = '>' then 383 Key := 'S'; 384 end if; 385 386 exit when At_EOL; 387 end loop; 388 end; 389 390 -- Decision entry 391 392 when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' => 393 Dtyp := C; 394 395 if C = 'A' then 396 Name_Len := 0; 397 while Nextc /= ' ' loop 398 Name_Len := Name_Len + 1; 399 Name_Buffer (Name_Len) := Getc; 400 end loop; 401 402 Nam := Name_Find; 403 404 else 405 Nam := No_Name; 406 end if; 407 408 Skip_Spaces; 409 410 -- Output header 411 412 declare 413 Loc : Source_Location; 414 415 begin 416 -- Acquire location information 417 418 if Dtyp = 'X' then 419 Loc := No_Source_Location; 420 else 421 Get_Source_Location (Loc); 422 end if; 423 424 SCO_Table.Append 425 ((C1 => Dtyp, 426 C2 => ' ', 427 From => Loc, 428 To => No_Source_Location, 429 Last => False, 430 Pragma_Aspect_Name => Nam, 431 others => <>)); 432 end; 433 434 -- Loop through terms in complex expression 435 436 C := Nextc; 437 while C /= CR and then C /= LF loop 438 if C = 'c' or else C = 't' or else C = 'f' then 439 Cond := C; 440 Skipc; 441 Get_Source_Location_Range (Loc1, Loc2); 442 SCO_Table.Append 443 ((C2 => Cond, 444 From => Loc1, 445 To => Loc2, 446 Last => False, 447 others => <>)); 448 449 elsif C = '!' or else 450 C = '&' or else 451 C = '|' 452 then 453 Skipc; 454 455 declare 456 Loc : Source_Location; 457 begin 458 Get_Source_Location (Loc); 459 SCO_Table.Append 460 ((C1 => C, 461 From => Loc, 462 Last => False, 463 others => <>)); 464 end; 465 466 elsif C = ' ' then 467 Skip_Spaces; 468 469 elsif C = 'T' or else C = 'F' then 470 471 -- Chaining indicator: skip for now??? 472 473 declare 474 Loc1, Loc2 : Source_Location; 475 pragma Unreferenced (Loc1, Loc2); 476 begin 477 Skipc; 478 Get_Source_Location_Range (Loc1, Loc2); 479 end; 480 481 else 482 raise Data_Error; 483 end if; 484 485 C := Nextc; 486 end loop; 487 488 -- Reset Last indication to True for last entry 489 490 SCO_Table.Table (SCO_Table.Last).Last := True; 491 492 -- No other SCO lines are possible 493 494 when others => 495 raise Data_Error; 496 end case; 497 498 Skip_EOL; 499 end loop; 500 501 -- Here with all SCO's stored, complete last SCO Unit table entry 502 503 SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last; 504end Get_SCOs; 505