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-2012, 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 183 if C = ' ' then 184 Skip_Spaces; 185 C := Nextc; 186 exit when C /= LF and then C /= CR; 187 end if; 188 end loop; 189 end Skip_EOL; 190 191 ----------------- 192 -- Skip_Spaces -- 193 ----------------- 194 195 procedure Skip_Spaces is 196 begin 197 while Nextc = ' ' loop 198 Skipc; 199 end loop; 200 end Skip_Spaces; 201 202 Buf : String (1 .. 32_768); 203 N : Natural; 204 -- Scratch buffer, and index into it 205 206 Nam : Name_Id; 207 208-- Start of processing for Get_SCOs 209 210begin 211 SCOs.Initialize; 212 213 -- Loop through lines of SCO information 214 215 while Nextc = 'C' loop 216 Skipc; 217 218 C := Getc; 219 220 -- Make sure first line is a header line 221 222 if SCO_Unit_Table.Last = 0 and then C /= ' ' then 223 raise Data_Error; 224 end if; 225 226 -- Otherwise dispatch on type of line 227 228 case C is 229 230 -- Header or instance table entry 231 232 when ' ' => 233 234 -- Complete previous entry if any 235 236 if SCO_Unit_Table.Last /= 0 then 237 SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := 238 SCO_Table.Last; 239 end if; 240 241 Skip_Spaces; 242 243 case Nextc is 244 245 -- Instance table entry 246 247 when 'i' => 248 declare 249 Inum : SCO_Instance_Index; 250 begin 251 Skipc; 252 Skip_Spaces; 253 254 Inum := SCO_Instance_Index (Get_Int); 255 SCO_Instance_Table.Increment_Last; 256 pragma Assert (SCO_Instance_Table.Last = Inum); 257 258 Skip_Spaces; 259 declare 260 SIE : SCO_Instance_Table_Entry 261 renames SCO_Instance_Table.Table (Inum); 262 begin 263 SIE.Inst_Dep_Num := Get_Int; 264 C := Getc; 265 pragma Assert (C = '|'); 266 Get_Source_Location (SIE.Inst_Loc); 267 268 if At_EOL then 269 SIE.Enclosing_Instance := 0; 270 else 271 Skip_Spaces; 272 SIE.Enclosing_Instance := 273 SCO_Instance_Index (Get_Int); 274 pragma Assert (SIE.Enclosing_Instance in 275 SCO_Instance_Table.First 276 .. SCO_Instance_Table.Last); 277 end if; 278 end; 279 end; 280 281 -- Unit header 282 283 when '0' .. '9' => 284 -- Scan out dependency number and file name 285 286 Dnum := Get_Int; 287 288 Skip_Spaces; 289 290 N := 0; 291 while Nextc > ' ' loop 292 N := N + 1; 293 Buf (N) := Getc; 294 end loop; 295 296 -- Make new unit table entry (will fill in To later) 297 298 SCO_Unit_Table.Append ( 299 (File_Name => new String'(Buf (1 .. N)), 300 Dep_Num => Dnum, 301 From => SCO_Table.Last + 1, 302 To => 0)); 303 304 when others => 305 raise Program_Error; 306 307 end case; 308 309 -- Statement entry 310 311 when 'S' | 's' => 312 declare 313 Typ : Character; 314 Key : Character; 315 316 begin 317 Key := 'S'; 318 319 -- If continuation, reset Last indication in last entry stored 320 -- for previous CS or cs line. 321 322 if C = 's' then 323 SCO_Table.Table (SCO_Table.Last).Last := False; 324 end if; 325 326 -- Initialize to scan items on one line 327 328 Skip_Spaces; 329 330 -- Loop through items on one line 331 332 loop 333 Nam := No_Name; 334 Typ := Nextc; 335 336 case Typ is 337 when '>' => 338 339 -- Dominance marker may be present only at entry point 340 341 pragma Assert (Key = 'S'); 342 343 Skipc; 344 Key := '>'; 345 Typ := Getc; 346 347 -- Sanity check on dominance marker type indication 348 349 pragma Assert (Typ in 'A' .. 'Z'); 350 351 when '1' .. '9' => 352 Typ := ' '; 353 354 when others => 355 Skipc; 356 if Typ = 'P' or else Typ = 'p' then 357 if Nextc not in '1' .. '9' then 358 Name_Len := 0; 359 loop 360 Name_Len := Name_Len + 1; 361 Name_Buffer (Name_Len) := Getc; 362 exit when Nextc = ':'; 363 end loop; 364 365 Skipc; -- Past ':' 366 367 Nam := Name_Find; 368 end if; 369 end if; 370 end case; 371 372 if Key = '>' and then Typ /= 'E' then 373 Get_Source_Location (Loc1); 374 Loc2 := No_Source_Location; 375 else 376 Get_Source_Location_Range (Loc1, Loc2); 377 end if; 378 379 SCO_Table.Append 380 ((C1 => Key, 381 C2 => Typ, 382 From => Loc1, 383 To => Loc2, 384 Last => At_EOL, 385 Pragma_Sloc => No_Location, 386 Pragma_Aspect_Name => Nam)); 387 388 if Key = '>' then 389 Key := 'S'; 390 end if; 391 392 exit when At_EOL; 393 end loop; 394 end; 395 396 -- Decision entry 397 398 when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' => 399 Dtyp := C; 400 401 if C = 'A' then 402 Name_Len := 0; 403 while Nextc /= ' ' loop 404 Name_Len := Name_Len + 1; 405 Name_Buffer (Name_Len) := Getc; 406 end loop; 407 408 Nam := Name_Find; 409 410 else 411 Nam := No_Name; 412 end if; 413 414 Skip_Spaces; 415 416 -- Output header 417 418 declare 419 Loc : Source_Location; 420 421 begin 422 -- Acquire location information 423 424 if Dtyp = 'X' then 425 Loc := No_Source_Location; 426 else 427 Get_Source_Location (Loc); 428 end if; 429 430 SCO_Table.Append 431 ((C1 => Dtyp, 432 C2 => ' ', 433 From => Loc, 434 To => No_Source_Location, 435 Last => False, 436 Pragma_Aspect_Name => Nam, 437 others => <>)); 438 end; 439 440 -- Loop through terms in complex expression 441 442 C := Nextc; 443 while C /= CR and then C /= LF loop 444 if C = 'c' or else C = 't' or else C = 'f' then 445 Cond := C; 446 Skipc; 447 Get_Source_Location_Range (Loc1, Loc2); 448 SCO_Table.Append 449 ((C2 => Cond, 450 From => Loc1, 451 To => Loc2, 452 Last => False, 453 others => <>)); 454 455 elsif C = '!' or else 456 C = '&' or else 457 C = '|' 458 then 459 Skipc; 460 461 declare 462 Loc : Source_Location; 463 begin 464 Get_Source_Location (Loc); 465 SCO_Table.Append 466 ((C1 => C, 467 From => Loc, 468 Last => False, 469 others => <>)); 470 end; 471 472 elsif C = ' ' then 473 Skip_Spaces; 474 475 elsif C = 'T' or else C = 'F' then 476 477 -- Chaining indicator: skip for now??? 478 479 declare 480 Loc1, Loc2 : Source_Location; 481 pragma Unreferenced (Loc1, Loc2); 482 begin 483 Skipc; 484 Get_Source_Location_Range (Loc1, Loc2); 485 end; 486 487 else 488 raise Data_Error; 489 end if; 490 491 C := Nextc; 492 end loop; 493 494 -- Reset Last indication to True for last entry 495 496 SCO_Table.Table (SCO_Table.Last).Last := True; 497 498 -- No other SCO lines are possible 499 500 when others => 501 raise Data_Error; 502 end case; 503 504 Skip_EOL; 505 end loop; 506 507 -- Here with all SCO's stored, complete last SCO Unit table entry 508 509 SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last; 510end Get_SCOs; 511