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-2014, 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 File_Index => 0, 301 Dep_Num => Dnum, 302 From => SCO_Table.Last + 1, 303 To => 0)); 304 305 when others => 306 raise Program_Error; 307 308 end case; 309 310 -- Statement entry 311 312 when 'S' | 's' => 313 declare 314 Typ : Character; 315 Key : Character; 316 317 begin 318 Key := 'S'; 319 320 -- If continuation, reset Last indication in last entry stored 321 -- for previous CS or cs line. 322 323 if C = 's' then 324 SCO_Table.Table (SCO_Table.Last).Last := False; 325 end if; 326 327 -- Initialize to scan items on one line 328 329 Skip_Spaces; 330 331 -- Loop through items on one line 332 333 loop 334 Nam := No_Name; 335 Typ := Nextc; 336 337 case Typ is 338 when '>' => 339 340 -- Dominance marker may be present only at entry point 341 342 pragma Assert (Key = 'S'); 343 344 Skipc; 345 Key := '>'; 346 Typ := Getc; 347 348 -- Sanity check on dominance marker type indication 349 350 pragma Assert (Typ in 'A' .. 'Z'); 351 352 when '1' .. '9' => 353 Typ := ' '; 354 355 when others => 356 Skipc; 357 if Typ = 'P' or else Typ = 'p' then 358 if Nextc not in '1' .. '9' then 359 Name_Len := 0; 360 loop 361 Name_Len := Name_Len + 1; 362 Name_Buffer (Name_Len) := Getc; 363 exit when Nextc = ':'; 364 end loop; 365 366 Skipc; -- Past ':' 367 368 Nam := Name_Find; 369 end if; 370 end if; 371 end case; 372 373 if Key = '>' and then Typ /= 'E' then 374 Get_Source_Location (Loc1); 375 Loc2 := No_Source_Location; 376 else 377 Get_Source_Location_Range (Loc1, Loc2); 378 end if; 379 380 SCO_Table.Append 381 ((C1 => Key, 382 C2 => Typ, 383 From => Loc1, 384 To => Loc2, 385 Last => At_EOL, 386 Pragma_Sloc => No_Location, 387 Pragma_Aspect_Name => Nam)); 388 389 if Key = '>' then 390 Key := 'S'; 391 end if; 392 393 exit when At_EOL; 394 end loop; 395 end; 396 397 -- Decision entry 398 399 when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' => 400 Dtyp := C; 401 402 if C = 'A' then 403 Name_Len := 0; 404 while Nextc /= ' ' loop 405 Name_Len := Name_Len + 1; 406 Name_Buffer (Name_Len) := Getc; 407 end loop; 408 409 Nam := Name_Find; 410 411 else 412 Nam := No_Name; 413 end if; 414 415 Skip_Spaces; 416 417 -- Output header 418 419 declare 420 Loc : Source_Location; 421 422 begin 423 -- Acquire location information 424 425 if Dtyp = 'X' then 426 Loc := No_Source_Location; 427 else 428 Get_Source_Location (Loc); 429 end if; 430 431 SCO_Table.Append 432 ((C1 => Dtyp, 433 C2 => ' ', 434 From => Loc, 435 To => No_Source_Location, 436 Last => False, 437 Pragma_Aspect_Name => Nam, 438 others => <>)); 439 end; 440 441 -- Loop through terms in complex expression 442 443 C := Nextc; 444 while C /= CR and then C /= LF loop 445 if C = 'c' or else C = 't' or else C = 'f' then 446 Cond := C; 447 Skipc; 448 Get_Source_Location_Range (Loc1, Loc2); 449 SCO_Table.Append 450 ((C2 => Cond, 451 From => Loc1, 452 To => Loc2, 453 Last => False, 454 others => <>)); 455 456 elsif C = '!' or else 457 C = '&' or else 458 C = '|' 459 then 460 Skipc; 461 462 declare 463 Loc : Source_Location; 464 begin 465 Get_Source_Location (Loc); 466 SCO_Table.Append 467 ((C1 => C, 468 From => Loc, 469 Last => False, 470 others => <>)); 471 end; 472 473 elsif C = ' ' then 474 Skip_Spaces; 475 476 elsif C = 'T' or else C = 'F' then 477 478 -- Chaining indicator: skip for now??? 479 480 declare 481 Loc1, Loc2 : Source_Location; 482 pragma Unreferenced (Loc1, Loc2); 483 begin 484 Skipc; 485 Get_Source_Location_Range (Loc1, Loc2); 486 end; 487 488 else 489 raise Data_Error; 490 end if; 491 492 C := Nextc; 493 end loop; 494 495 -- Reset Last indication to True for last entry 496 497 SCO_Table.Table (SCO_Table.Last).Last := True; 498 499 -- No other SCO lines are possible 500 501 when others => 502 raise Data_Error; 503 end case; 504 505 Skip_EOL; 506 end loop; 507 508 -- Here with all SCO's stored, complete last SCO Unit table entry 509 510 SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last; 511end Get_SCOs; 512