1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R _ S C O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2009-2021, 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 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Debug; use Debug; 29with Errout; use Errout; 30with Lib; use Lib; 31with Lib.Util; use Lib.Util; 32with Namet; use Namet; 33with Nlists; use Nlists; 34with Opt; use Opt; 35with Output; use Output; 36with Put_SCOs; 37with SCOs; use SCOs; 38with Sem; use Sem; 39with Sem_Util; use Sem_Util; 40with Sinfo; use Sinfo; 41with Sinfo.Nodes; use Sinfo.Nodes; 42with Sinfo.Utils; use Sinfo.Utils; 43with Sinput; use Sinput; 44with Snames; use Snames; 45with Table; 46 47with GNAT.HTable; use GNAT.HTable; 48with GNAT.Heap_Sort_G; 49 50package body Par_SCO is 51 52 -------------------------- 53 -- First-pass SCO table -- 54 -------------------------- 55 56 -- The Short_Circuit_And_Or pragma enables one to use AND and OR operators 57 -- in source code while the ones used with booleans will be interpreted as 58 -- their short circuit alternatives (AND THEN and OR ELSE). Thus, the true 59 -- meaning of these operators is known only after the semantic analysis. 60 61 -- However, decision SCOs include short circuit operators only. The SCO 62 -- information generation pass must be done before expansion, hence before 63 -- the semantic analysis. Because of this, the SCO information generation 64 -- is done in two passes. 65 66 -- The first one (SCO_Record_Raw, before semantic analysis) completes the 67 -- SCO_Raw_Table assuming all AND/OR operators are short circuit ones. 68 -- Then, the semantic analysis determines which operators are promoted to 69 -- short circuit ones. Finally, the second pass (SCO_Record_Filtered) 70 -- translates the SCO_Raw_Table to SCO_Table, taking care of removing the 71 -- remaining AND/OR operators and of adjusting decisions accordingly 72 -- (splitting decisions, removing empty ones, etc.). 73 74 type SCO_Generation_State_Type is (None, Raw, Filtered); 75 SCO_Generation_State : SCO_Generation_State_Type := None; 76 -- Keep track of the SCO generation state: this will prevent us from 77 -- running some steps multiple times (the second pass has to be started 78 -- from multiple places). 79 80 package SCO_Raw_Table is new Table.Table 81 (Table_Component_Type => SCO_Table_Entry, 82 Table_Index_Type => Nat, 83 Table_Low_Bound => 1, 84 Table_Initial => 500, 85 Table_Increment => 300, 86 Table_Name => "Raw_Table"); 87 88 ----------------------- 89 -- Unit Number Table -- 90 ----------------------- 91 92 -- This table parallels the SCO_Unit_Table, keeping track of the unit 93 -- numbers corresponding to the entries made in this table, so that before 94 -- writing out the SCO information to the ALI file, we can fill in the 95 -- proper dependency numbers and file names. 96 97 -- Note that the zeroth entry is here for convenience in sorting the table; 98 -- the real lower bound is 1. 99 100 package SCO_Unit_Number_Table is new Table.Table 101 (Table_Component_Type => Unit_Number_Type, 102 Table_Index_Type => SCO_Unit_Index, 103 Table_Low_Bound => 0, -- see note above on sort 104 Table_Initial => 20, 105 Table_Increment => 200, 106 Table_Name => "SCO_Unit_Number_Entry"); 107 108 ------------------------------------------ 109 -- Condition/Operator/Pragma Hash Table -- 110 ------------------------------------------ 111 112 -- We need to be able to get to conditions quickly for handling the calls 113 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to 114 -- handle calls to Set_SCO_Pragma_Enabled (the same holds for operators and 115 -- Set_SCO_Logical_Operator). For this purpose we identify the conditions, 116 -- operators and pragmas in the table by their starting sloc, and use this 117 -- hash table to map from these sloc values to SCO_Table indexes. 118 119 type Header_Num is new Integer range 0 .. 996; 120 -- Type for hash table headers 121 122 function Hash (F : Source_Ptr) return Header_Num; 123 -- Function to Hash source pointer value 124 125 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean; 126 -- Function to test two keys for equality 127 128 function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean; 129 -- Function to test for source locations order 130 131 package SCO_Raw_Hash_Table is new Simple_HTable 132 (Header_Num, Int, 0, Source_Ptr, Hash, Equal); 133 -- The actual hash table 134 135 -------------------------- 136 -- Internal Subprograms -- 137 -------------------------- 138 139 function Has_Decision (N : Node_Id) return Boolean; 140 -- N is the node for a subexpression. Returns True if the subexpression 141 -- contains a nested decision (i.e. either is a logical operator, or 142 -- contains a logical operator in its subtree). 143 -- 144 -- This must be used in the first pass (SCO_Record_Raw) only: here AND/OR 145 -- operators are considered as short circuit, just in case the 146 -- Short_Circuit_And_Or pragma is used: only real short circuit operations 147 -- will be kept in the secord pass. 148 149 type Tristate is (False, True, Unknown); 150 151 function Is_Logical_Operator (N : Node_Id) return Tristate; 152 -- N is the node for a subexpression. This procedure determines whether N 153 -- is a logical operator: True for short circuit conditions, Unknown for OR 154 -- and AND (the Short_Circuit_And_Or pragma may be used) and False 155 -- otherwise. Note that in cases where True is returned, callers assume 156 -- Nkind (N) in N_Op. 157 158 function To_Source_Location (S : Source_Ptr) return Source_Location; 159 -- Converts Source_Ptr value to Source_Location (line/col) format 160 161 procedure Process_Decisions 162 (N : Node_Id; 163 T : Character; 164 Pragma_Sloc : Source_Ptr); 165 -- If N is Empty, has no effect. Otherwise scans the tree for the node N, 166 -- to output any decisions it contains. T is one of IEGPWX (for context of 167 -- expression: if/exit when/entry guard/pragma/while/expression). If T is 168 -- other than X, the node N is the if expression involved, and a decision 169 -- is always present (at the very least a simple decision is present at the 170 -- top level). 171 172 procedure Process_Decisions 173 (L : List_Id; 174 T : Character; 175 Pragma_Sloc : Source_Ptr); 176 -- Calls above procedure for each element of the list L 177 178 procedure Set_Raw_Table_Entry 179 (C1 : Character; 180 C2 : Character; 181 From : Source_Ptr; 182 To : Source_Ptr; 183 Last : Boolean; 184 Pragma_Sloc : Source_Ptr := No_Location; 185 Pragma_Aspect_Name : Name_Id := No_Name); 186 -- Append an entry to SCO_Raw_Table with fields set as per arguments 187 188 type Dominant_Info is record 189 K : Character; 190 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant 191 192 N : Node_Id; 193 -- Node providing the Sloc(s) for the dominance marker 194 end record; 195 No_Dominant : constant Dominant_Info := (' ', Empty); 196 197 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr); 198 -- Add one entry from the instance table to the corresponding SCO table 199 200 procedure Traverse_Declarations_Or_Statements 201 (L : List_Id; 202 D : Dominant_Info := No_Dominant; 203 P : Node_Id := Empty); 204 -- Process L, a list of statements or declarations dominated by D. If P is 205 -- present, it is processed as though it had been prepended to L. 206 207 function Traverse_Declarations_Or_Statements 208 (L : List_Id; 209 D : Dominant_Info := No_Dominant; 210 P : Node_Id := Empty) return Dominant_Info; 211 -- Same as above, and returns dominant information corresponding to the 212 -- last node with SCO in L. 213 214 -- The following Traverse_* routines perform appropriate calls to 215 -- Traverse_Declarations_Or_Statements to traverse specific node kinds. 216 -- Parameter D, when present, indicates the dominant of the first 217 -- declaration or statement within N. 218 219 procedure Traverse_Generic_Package_Declaration (N : Node_Id); 220 221 procedure Traverse_Handled_Statement_Sequence 222 (N : Node_Id; 223 D : Dominant_Info := No_Dominant); 224 225 procedure Traverse_Package_Body (N : Node_Id); 226 227 procedure Traverse_Package_Declaration 228 (N : Node_Id; 229 D : Dominant_Info := No_Dominant); 230 231 procedure Traverse_Subprogram_Or_Task_Body 232 (N : Node_Id; 233 D : Dominant_Info := No_Dominant); 234 235 procedure Traverse_Protected_Or_Task_Definition (N : Node_Id); 236 237 -- Note regarding traversals: In a few cases where an Alternatives list is 238 -- involved, pragmas such as "pragma Page" may show up before the first 239 -- alternative. We skip them because we're out of statement or declaration 240 -- context, so these can't be pragmas of interest for SCO purposes, and 241 -- the regular alternative processing typically involves attribute queries 242 -- which aren't valid for a pragma. 243 244 procedure Write_SCOs_To_ALI_File is new Put_SCOs; 245 -- Write SCO information to the ALI file using routines in Lib.Util 246 247 ---------- 248 -- dsco -- 249 ---------- 250 251 procedure dsco is 252 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry); 253 -- Dump a SCO table entry 254 255 ---------------- 256 -- Dump_Entry -- 257 ---------------- 258 259 procedure Dump_Entry (Index : Nat; T : SCO_Table_Entry) is 260 begin 261 Write_Str (" "); 262 Write_Int (Index); 263 Write_Char ('.'); 264 265 if T.C1 /= ' ' then 266 Write_Str (" C1 = '"); 267 Write_Char (T.C1); 268 Write_Char ('''); 269 end if; 270 271 if T.C2 /= ' ' then 272 Write_Str (" C2 = '"); 273 Write_Char (T.C2); 274 Write_Char ('''); 275 end if; 276 277 if T.From /= No_Source_Location then 278 Write_Str (" From = "); 279 Write_Int (Int (T.From.Line)); 280 Write_Char (':'); 281 Write_Int (Int (T.From.Col)); 282 end if; 283 284 if T.To /= No_Source_Location then 285 Write_Str (" To = "); 286 Write_Int (Int (T.To.Line)); 287 Write_Char (':'); 288 Write_Int (Int (T.To.Col)); 289 end if; 290 291 if T.Last then 292 Write_Str (" True"); 293 else 294 Write_Str (" False"); 295 end if; 296 297 Write_Eol; 298 end Dump_Entry; 299 300 -- Start of processing for dsco 301 302 begin 303 -- Dump SCO unit table 304 305 Write_Line ("SCO Unit Table"); 306 Write_Line ("--------------"); 307 308 for Index in 1 .. SCO_Unit_Table.Last loop 309 declare 310 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index); 311 312 begin 313 Write_Str (" "); 314 Write_Int (Int (Index)); 315 Write_Str (" Dep_Num = "); 316 Write_Int (Int (UTE.Dep_Num)); 317 Write_Str (" From = "); 318 Write_Int (Int (UTE.From)); 319 Write_Str (" To = "); 320 Write_Int (Int (UTE.To)); 321 322 Write_Str (" File_Name = """); 323 324 if UTE.File_Name /= null then 325 Write_Str (UTE.File_Name.all); 326 end if; 327 328 Write_Char ('"'); 329 Write_Eol; 330 end; 331 end loop; 332 333 -- Dump SCO Unit number table if it contains any entries 334 335 if SCO_Unit_Number_Table.Last >= 1 then 336 Write_Eol; 337 Write_Line ("SCO Unit Number Table"); 338 Write_Line ("---------------------"); 339 340 for Index in 1 .. SCO_Unit_Number_Table.Last loop 341 Write_Str (" "); 342 Write_Int (Int (Index)); 343 Write_Str (". Unit_Number = "); 344 Write_Int (Int (SCO_Unit_Number_Table.Table (Index))); 345 Write_Eol; 346 end loop; 347 end if; 348 349 -- Dump SCO raw-table 350 351 Write_Eol; 352 Write_Line ("SCO Raw Table"); 353 Write_Line ("---------"); 354 355 if SCO_Generation_State = Filtered then 356 Write_Line ("Empty (free'd after second pass)"); 357 else 358 for Index in 1 .. SCO_Raw_Table.Last loop 359 Dump_Entry (Index, SCO_Raw_Table.Table (Index)); 360 end loop; 361 end if; 362 363 -- Dump SCO table itself 364 365 Write_Eol; 366 Write_Line ("SCO Filtered Table"); 367 Write_Line ("---------"); 368 369 for Index in 1 .. SCO_Table.Last loop 370 Dump_Entry (Index, SCO_Table.Table (Index)); 371 end loop; 372 end dsco; 373 374 ----------- 375 -- Equal -- 376 ----------- 377 378 function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is 379 begin 380 return F1 = F2; 381 end Equal; 382 383 ------- 384 -- < -- 385 ------- 386 387 function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean is 388 begin 389 return S1.Line < S2.Line 390 or else (S1.Line = S2.Line and then S1.Col < S2.Col); 391 end "<"; 392 393 ------------------ 394 -- Has_Decision -- 395 ------------------ 396 397 function Has_Decision (N : Node_Id) return Boolean is 398 function Check_Node (N : Node_Id) return Traverse_Result; 399 -- Determine if Nkind (N) indicates the presence of a decision (i.e. N 400 -- is a logical operator, which is a decision in itself, or an 401 -- IF-expression whose Condition attribute is a decision). 402 403 ---------------- 404 -- Check_Node -- 405 ---------------- 406 407 function Check_Node (N : Node_Id) return Traverse_Result is 408 begin 409 -- If we are not sure this is a logical operator (AND and OR may be 410 -- turned into logical operators with the Short_Circuit_And_Or 411 -- pragma), assume it is. Putative decisions will be discarded if 412 -- needed in the secord pass. 413 414 if Is_Logical_Operator (N) /= False 415 or else Nkind (N) = N_If_Expression 416 then 417 return Abandon; 418 else 419 return OK; 420 end if; 421 end Check_Node; 422 423 function Traverse is new Traverse_Func (Check_Node); 424 425 -- Start of processing for Has_Decision 426 427 begin 428 return Traverse (N) = Abandon; 429 end Has_Decision; 430 431 ---------- 432 -- Hash -- 433 ---------- 434 435 function Hash (F : Source_Ptr) return Header_Num is 436 begin 437 return Header_Num (Nat (F) mod 997); 438 end Hash; 439 440 ---------------- 441 -- Initialize -- 442 ---------------- 443 444 procedure Initialize is 445 begin 446 SCO_Unit_Number_Table.Init; 447 448 -- The SCO_Unit_Number_Table entry with index 0 is intentionally set 449 -- aside to be used as temporary for sorting. 450 451 SCO_Unit_Number_Table.Increment_Last; 452 end Initialize; 453 454 ------------------------- 455 -- Is_Logical_Operator -- 456 ------------------------- 457 458 function Is_Logical_Operator (N : Node_Id) return Tristate is 459 begin 460 if Nkind (N) in N_And_Then | N_Op_Not | N_Or_Else then 461 return True; 462 elsif Nkind (N) in N_Op_And | N_Op_Or then 463 return Unknown; 464 else 465 return False; 466 end if; 467 end Is_Logical_Operator; 468 469 ----------------------- 470 -- Process_Decisions -- 471 ----------------------- 472 473 -- Version taking a list 474 475 procedure Process_Decisions 476 (L : List_Id; 477 T : Character; 478 Pragma_Sloc : Source_Ptr) 479 is 480 N : Node_Id; 481 482 begin 483 if L /= No_List then 484 N := First (L); 485 while Present (N) loop 486 Process_Decisions (N, T, Pragma_Sloc); 487 Next (N); 488 end loop; 489 end if; 490 end Process_Decisions; 491 492 -- Version taking a node 493 494 Current_Pragma_Sloc : Source_Ptr := No_Location; 495 -- While processing a pragma, this is set to the sloc of the N_Pragma node 496 497 procedure Process_Decisions 498 (N : Node_Id; 499 T : Character; 500 Pragma_Sloc : Source_Ptr) 501 is 502 Mark : Nat; 503 -- This is used to mark the location of a decision sequence in the SCO 504 -- table. We use it for backing out a simple decision in an expression 505 -- context that contains only NOT operators. 506 507 Mark_Hash : Nat; 508 -- Likewise for the putative SCO_Raw_Hash_Table entries: see below 509 510 type Hash_Entry is record 511 Sloc : Source_Ptr; 512 SCO_Index : Nat; 513 end record; 514 -- We must register all conditions/pragmas in SCO_Raw_Hash_Table. 515 -- However we cannot register them in the same time we are adding the 516 -- corresponding SCO entries to the raw table since we may discard them 517 -- later on. So instead we put all putative conditions into Hash_Entries 518 -- (see below) and register them once we are sure we keep them. 519 -- 520 -- This data structure holds the conditions/pragmas to register in 521 -- SCO_Raw_Hash_Table. 522 523 package Hash_Entries is new Table.Table 524 (Table_Component_Type => Hash_Entry, 525 Table_Index_Type => Nat, 526 Table_Low_Bound => 1, 527 Table_Initial => 10, 528 Table_Increment => 10, 529 Table_Name => "Hash_Entries"); 530 -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before 531 -- they are registered in SCO_Raw_Hash_Table. 532 533 X_Not_Decision : Boolean; 534 -- This flag keeps track of whether a decision sequence in the SCO table 535 -- contains only NOT operators, and is for an expression context (T=X). 536 -- The flag will be set False if T is other than X, or if an operator 537 -- other than NOT is in the sequence. 538 539 procedure Output_Decision_Operand (N : Node_Id); 540 -- The node N is the top level logical operator of a decision, or it is 541 -- one of the operands of a logical operator belonging to a single 542 -- complex decision. This routine outputs the sequence of table entries 543 -- corresponding to the node. Note that we do not process the sub- 544 -- operands to look for further decisions, that processing is done in 545 -- Process_Decision_Operand, because we can't get decisions mixed up in 546 -- the global table. Call has no effect if N is Empty. 547 548 procedure Output_Element (N : Node_Id); 549 -- Node N is an operand of a logical operator that is not itself a 550 -- logical operator, or it is a simple decision. This routine outputs 551 -- the table entry for the element, with C1 set to ' '. Last is set 552 -- False, and an entry is made in the condition hash table. 553 554 procedure Output_Header (T : Character); 555 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ 556 -- PRAGMA, and 'X' for the expression case. 557 558 procedure Process_Decision_Operand (N : Node_Id); 559 -- This is called on node N, the top level node of a decision, or on one 560 -- of its operands or suboperands after generating the full output for 561 -- the complex decision. It process the suboperands of the decision 562 -- looking for nested decisions. 563 564 function Process_Node (N : Node_Id) return Traverse_Result; 565 -- Processes one node in the traversal, looking for logical operators, 566 -- and if one is found, outputs the appropriate table entries. 567 568 ----------------------------- 569 -- Output_Decision_Operand -- 570 ----------------------------- 571 572 procedure Output_Decision_Operand (N : Node_Id) is 573 C1 : Character; 574 C2 : Character; 575 -- C1 holds a character that identifies the operation while C2 576 -- indicates whether we are sure (' ') or not ('?') this operation 577 -- belongs to the decision. '?' entries will be filtered out in the 578 -- second (SCO_Record_Filtered) pass. 579 580 L : Node_Id; 581 T : Tristate; 582 583 begin 584 if No (N) then 585 return; 586 end if; 587 588 T := Is_Logical_Operator (N); 589 590 -- Logical operator 591 592 if T /= False then 593 if Nkind (N) = N_Op_Not then 594 C1 := '!'; 595 L := Empty; 596 597 else 598 L := Left_Opnd (N); 599 600 if Nkind (N) in N_Op_Or | N_Or_Else then 601 C1 := '|'; 602 else pragma Assert (Nkind (N) in N_Op_And | N_And_Then); 603 C1 := '&'; 604 end if; 605 end if; 606 607 if T = True then 608 C2 := ' '; 609 else 610 C2 := '?'; 611 end if; 612 613 Set_Raw_Table_Entry 614 (C1 => C1, 615 C2 => C2, 616 From => Sloc (N), 617 To => No_Location, 618 Last => False); 619 620 Hash_Entries.Append ((Sloc (N), SCO_Raw_Table.Last)); 621 622 Output_Decision_Operand (L); 623 Output_Decision_Operand (Right_Opnd (N)); 624 625 -- Not a logical operator 626 627 else 628 Output_Element (N); 629 end if; 630 end Output_Decision_Operand; 631 632 -------------------- 633 -- Output_Element -- 634 -------------------- 635 636 procedure Output_Element (N : Node_Id) is 637 FSloc : Source_Ptr; 638 LSloc : Source_Ptr; 639 begin 640 Sloc_Range (N, FSloc, LSloc); 641 Set_Raw_Table_Entry 642 (C1 => ' ', 643 C2 => 'c', 644 From => FSloc, 645 To => LSloc, 646 Last => False); 647 Hash_Entries.Append ((FSloc, SCO_Raw_Table.Last)); 648 end Output_Element; 649 650 ------------------- 651 -- Output_Header -- 652 ------------------- 653 654 procedure Output_Header (T : Character) is 655 Loc : Source_Ptr := No_Location; 656 -- Node whose Sloc is used for the decision 657 658 Nam : Name_Id := No_Name; 659 -- For the case of an aspect, aspect name 660 661 begin 662 case T is 663 when 'I' | 'E' | 'W' | 'a' | 'A' => 664 665 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of 666 -- the parent of the expression. 667 668 Loc := Sloc (Parent (N)); 669 670 if T = 'a' or else T = 'A' then 671 Nam := Chars (Identifier (Parent (N))); 672 end if; 673 674 when 'G' | 'P' => 675 676 -- For entry guard, the token sloc is from the N_Entry_Body. 677 -- For PRAGMA, we must get the location from the pragma node. 678 -- Argument N is the pragma argument, and we have to go up 679 -- two levels (through the pragma argument association) to 680 -- get to the pragma node itself. For the guard on a select 681 -- alternative, we do not have access to the token location for 682 -- the WHEN, so we use the first sloc of the condition itself. 683 -- First_Sloc gives the most sensible result, but we have to 684 -- beware of also using it when computing the dominance marker 685 -- sloc (in the Set_Statement_Entry procedure), as this is not 686 -- fully equivalent to the "To" sloc computed by 687 -- Sloc_Range (Guard, To, From). 688 689 if Nkind (Parent (N)) in N_Accept_Alternative 690 | N_Delay_Alternative 691 | N_Terminate_Alternative 692 then 693 Loc := First_Sloc (N); 694 else 695 Loc := Sloc (Parent (Parent (N))); 696 end if; 697 698 when 'X' => 699 700 -- For an expression, no Sloc 701 702 null; 703 704 -- No other possibilities 705 706 when others => 707 raise Program_Error; 708 end case; 709 710 Set_Raw_Table_Entry 711 (C1 => T, 712 C2 => ' ', 713 From => Loc, 714 To => No_Location, 715 Last => False, 716 Pragma_Sloc => Pragma_Sloc, 717 Pragma_Aspect_Name => Nam); 718 719 -- For an aspect specification, which will be rewritten into a 720 -- pragma, enter a hash table entry now. 721 722 if T = 'a' then 723 Hash_Entries.Append ((Loc, SCO_Raw_Table.Last)); 724 end if; 725 end Output_Header; 726 727 ------------------------------ 728 -- Process_Decision_Operand -- 729 ------------------------------ 730 731 procedure Process_Decision_Operand (N : Node_Id) is 732 begin 733 if Is_Logical_Operator (N) /= False then 734 if Nkind (N) /= N_Op_Not then 735 Process_Decision_Operand (Left_Opnd (N)); 736 X_Not_Decision := False; 737 end if; 738 739 Process_Decision_Operand (Right_Opnd (N)); 740 741 else 742 Process_Decisions (N, 'X', Pragma_Sloc); 743 end if; 744 end Process_Decision_Operand; 745 746 ------------------ 747 -- Process_Node -- 748 ------------------ 749 750 function Process_Node (N : Node_Id) return Traverse_Result is 751 begin 752 case Nkind (N) is 753 754 -- Logical operators, output table entries and then process 755 -- operands recursively to deal with nested conditions. 756 757 when N_And_Then 758 | N_Op_And 759 | N_Op_Not 760 | N_Op_Or 761 | N_Or_Else 762 => 763 declare 764 T : Character; 765 766 begin 767 -- If outer level, then type comes from call, otherwise it 768 -- is more deeply nested and counts as X for expression. 769 770 if N = Process_Decisions.N then 771 T := Process_Decisions.T; 772 else 773 T := 'X'; 774 end if; 775 776 -- Output header for sequence 777 778 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; 779 Mark := SCO_Raw_Table.Last; 780 Mark_Hash := Hash_Entries.Last; 781 Output_Header (T); 782 783 -- Output the decision 784 785 Output_Decision_Operand (N); 786 787 -- If the decision was in an expression context (T = 'X') 788 -- and contained only NOT operators, then we don't output 789 -- it, so delete it. 790 791 if X_Not_Decision then 792 SCO_Raw_Table.Set_Last (Mark); 793 Hash_Entries.Set_Last (Mark_Hash); 794 795 -- Otherwise, set Last in last table entry to mark end 796 797 else 798 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True; 799 end if; 800 801 -- Process any embedded decisions 802 803 Process_Decision_Operand (N); 804 return Skip; 805 end; 806 807 -- Case expression 808 809 -- Really hard to believe this is correct given the special 810 -- handling for if expressions below ??? 811 812 when N_Case_Expression => 813 return OK; -- ??? 814 815 -- If expression, processed like an if statement 816 817 when N_If_Expression => 818 declare 819 Cond : constant Node_Id := First (Expressions (N)); 820 Thnx : constant Node_Id := Next (Cond); 821 Elsx : constant Node_Id := Next (Thnx); 822 823 begin 824 Process_Decisions (Cond, 'I', Pragma_Sloc); 825 Process_Decisions (Thnx, 'X', Pragma_Sloc); 826 Process_Decisions (Elsx, 'X', Pragma_Sloc); 827 return Skip; 828 end; 829 830 when N_Quantified_Expression => 831 declare 832 Cond : constant Node_Id := Condition (N); 833 begin 834 Process_Decisions (Cond, 'W', Pragma_Sloc); 835 return Skip; 836 end; 837 838 -- All other cases, continue scan 839 840 when others => 841 return OK; 842 end case; 843 end Process_Node; 844 845 procedure Traverse is new Traverse_Proc (Process_Node); 846 847 -- Start of processing for Process_Decisions 848 849 begin 850 if No (N) then 851 return; 852 end if; 853 854 Hash_Entries.Init; 855 856 -- See if we have simple decision at outer level and if so then 857 -- generate the decision entry for this simple decision. A simple 858 -- decision is a boolean expression (which is not a logical operator 859 -- or short circuit form) appearing as the operand of an IF, WHILE, 860 -- EXIT WHEN, or special PRAGMA construct. 861 862 if T /= 'X' and then Is_Logical_Operator (N) = False then 863 Output_Header (T); 864 Output_Element (N); 865 866 -- Change Last in last table entry to True to mark end of 867 -- sequence, which is this case is only one element long. 868 869 SCO_Raw_Table.Table (SCO_Raw_Table.Last).Last := True; 870 end if; 871 872 Traverse (N); 873 874 -- Now we have the definitive set of SCO entries, register them in the 875 -- corresponding hash table. 876 877 for J in 1 .. Hash_Entries.Last loop 878 SCO_Raw_Hash_Table.Set 879 (Hash_Entries.Table (J).Sloc, 880 Hash_Entries.Table (J).SCO_Index); 881 end loop; 882 883 Hash_Entries.Free; 884 end Process_Decisions; 885 886 ----------- 887 -- pscos -- 888 ----------- 889 890 procedure pscos is 891 procedure Write_Info_Char (C : Character) renames Write_Char; 892 -- Write one character; 893 894 procedure Write_Info_Initiate (Key : Character) renames Write_Char; 895 -- Start new one and write one character; 896 897 procedure Write_Info_Nat (N : Nat); 898 -- Write value of N 899 900 procedure Write_Info_Terminate renames Write_Eol; 901 -- Terminate current line 902 903 -------------------- 904 -- Write_Info_Nat -- 905 -------------------- 906 907 procedure Write_Info_Nat (N : Nat) is 908 begin 909 Write_Int (N); 910 end Write_Info_Nat; 911 912 procedure Debug_Put_SCOs is new Put_SCOs; 913 914 -- Start of processing for pscos 915 916 begin 917 Debug_Put_SCOs; 918 end pscos; 919 920 --------------------- 921 -- Record_Instance -- 922 --------------------- 923 924 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is 925 Inst_Src : constant Source_File_Index := 926 Get_Source_File_Index (Inst_Sloc); 927 begin 928 SCO_Instance_Table.Append 929 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)), 930 Inst_Loc => To_Source_Location (Inst_Sloc), 931 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src)))); 932 933 pragma Assert 934 (SCO_Instance_Table.Last = SCO_Instance_Index (Id)); 935 end Record_Instance; 936 937 ---------------- 938 -- SCO_Output -- 939 ---------------- 940 941 procedure SCO_Output is 942 procedure Populate_SCO_Instance_Table is 943 new Sinput.Iterate_On_Instances (Record_Instance); 944 945 begin 946 pragma Assert (SCO_Generation_State = Filtered); 947 948 if Debug_Flag_Dot_OO then 949 dsco; 950 end if; 951 952 Populate_SCO_Instance_Table; 953 954 -- Sort the unit tables based on dependency numbers 955 956 Unit_Table_Sort : declare 957 function Lt (Op1 : Natural; Op2 : Natural) return Boolean; 958 -- Comparison routine for sort call 959 960 procedure Move (From : Natural; To : Natural); 961 -- Move routine for sort call 962 963 -------- 964 -- Lt -- 965 -------- 966 967 function Lt (Op1 : Natural; Op2 : Natural) return Boolean is 968 begin 969 return 970 Dependency_Num 971 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1))) 972 < 973 Dependency_Num 974 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2))); 975 end Lt; 976 977 ---------- 978 -- Move -- 979 ---------- 980 981 procedure Move (From : Natural; To : Natural) is 982 begin 983 SCO_Unit_Table.Table (SCO_Unit_Index (To)) := 984 SCO_Unit_Table.Table (SCO_Unit_Index (From)); 985 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) := 986 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From)); 987 end Move; 988 989 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 990 991 -- Start of processing for Unit_Table_Sort 992 993 begin 994 Sorting.Sort (Integer (SCO_Unit_Table.Last)); 995 end Unit_Table_Sort; 996 997 -- Loop through entries in the unit table to set file name and 998 -- dependency number entries. 999 1000 for J in 1 .. SCO_Unit_Table.Last loop 1001 declare 1002 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J); 1003 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J); 1004 1005 begin 1006 Get_Name_String (Reference_Name (Source_Index (U))); 1007 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len)); 1008 UTE.Dep_Num := Dependency_Num (U); 1009 end; 1010 end loop; 1011 1012 -- Now the tables are all setup for output to the ALI file 1013 1014 Write_SCOs_To_ALI_File; 1015 end SCO_Output; 1016 1017 ------------------------- 1018 -- SCO_Pragma_Disabled -- 1019 ------------------------- 1020 1021 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is 1022 Index : Nat; 1023 1024 begin 1025 if Loc = No_Location then 1026 return False; 1027 end if; 1028 1029 Index := SCO_Raw_Hash_Table.Get (Loc); 1030 1031 -- The test here for zero is to deal with possible previous errors, and 1032 -- for the case of pragma statement SCOs, for which we always set the 1033 -- Pragma_Sloc even if the particular pragma cannot be specifically 1034 -- disabled. 1035 1036 if Index /= 0 then 1037 declare 1038 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); 1039 1040 begin 1041 case T.C1 is 1042 when 'S' => 1043 -- Pragma statement 1044 1045 return T.C2 = 'p'; 1046 1047 when 'A' => 1048 -- Aspect decision (enabled) 1049 1050 return False; 1051 1052 when 'a' => 1053 -- Aspect decision (not enabled) 1054 1055 return True; 1056 1057 when ASCII.NUL => 1058 -- Nullified disabled SCO 1059 1060 return True; 1061 1062 when others => 1063 raise Program_Error; 1064 end case; 1065 end; 1066 1067 else 1068 return False; 1069 end if; 1070 end SCO_Pragma_Disabled; 1071 1072 -------------------- 1073 -- SCO_Record_Raw -- 1074 -------------------- 1075 1076 procedure SCO_Record_Raw (U : Unit_Number_Type) is 1077 procedure Traverse_Aux_Decls (N : Node_Id); 1078 -- Traverse the Aux_Decls_Node of compilation unit N 1079 1080 ------------------------ 1081 -- Traverse_Aux_Decls -- 1082 ------------------------ 1083 1084 procedure Traverse_Aux_Decls (N : Node_Id) is 1085 ADN : constant Node_Id := Aux_Decls_Node (N); 1086 1087 begin 1088 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); 1089 Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); 1090 1091 -- Declarations and Actions do not correspond to source constructs, 1092 -- they contain only nodes from expansion, so at this point they 1093 -- should still be empty: 1094 1095 pragma Assert (No (Declarations (ADN))); 1096 pragma Assert (No (Actions (ADN))); 1097 end Traverse_Aux_Decls; 1098 1099 -- Local variables 1100 1101 From : Nat; 1102 Lu : Node_Id; 1103 1104 -- Start of processing for SCO_Record_Raw 1105 1106 begin 1107 -- It is legitimate to run this pass multiple times (once per unit) so 1108 -- run it even if it was already run before. 1109 1110 pragma Assert (SCO_Generation_State in None .. Raw); 1111 SCO_Generation_State := Raw; 1112 1113 -- Ignore call if not generating code and generating SCO's 1114 1115 if not (Generate_SCO and then Operating_Mode = Generate_Code) then 1116 return; 1117 end if; 1118 1119 -- Ignore call if this unit already recorded 1120 1121 for J in 1 .. SCO_Unit_Number_Table.Last loop 1122 if U = SCO_Unit_Number_Table.Table (J) then 1123 return; 1124 end if; 1125 end loop; 1126 1127 -- Otherwise record starting entry 1128 1129 From := SCO_Raw_Table.Last + 1; 1130 1131 -- Get Unit (checking case of subunit) 1132 1133 Lu := Unit (Cunit (U)); 1134 1135 if Nkind (Lu) = N_Subunit then 1136 Lu := Proper_Body (Lu); 1137 end if; 1138 1139 -- Traverse the unit 1140 1141 Traverse_Aux_Decls (Cunit (U)); 1142 1143 case Nkind (Lu) is 1144 when N_Generic_Instantiation 1145 | N_Generic_Package_Declaration 1146 | N_Package_Body 1147 | N_Package_Declaration 1148 | N_Protected_Body 1149 | N_Subprogram_Body 1150 | N_Subprogram_Declaration 1151 | N_Task_Body 1152 => 1153 Traverse_Declarations_Or_Statements (L => No_List, P => Lu); 1154 1155 -- All other cases of compilation units (e.g. renamings), generate no 1156 -- SCO information. 1157 1158 when others => 1159 null; 1160 end case; 1161 1162 -- Make entry for new unit in unit tables, we will fill in the file 1163 -- name and dependency numbers later. 1164 1165 SCO_Unit_Table.Append ( 1166 (Dep_Num => 0, 1167 File_Name => null, 1168 File_Index => Get_Source_File_Index (Sloc (Lu)), 1169 From => From, 1170 To => SCO_Raw_Table.Last)); 1171 1172 SCO_Unit_Number_Table.Append (U); 1173 end SCO_Record_Raw; 1174 1175 ----------------------- 1176 -- Set_SCO_Condition -- 1177 ----------------------- 1178 1179 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is 1180 1181 -- SCO annotations are not processed after the filtering pass 1182 1183 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw); 1184 1185 Constant_Condition_Code : constant array (Boolean) of Character := 1186 (False => 'f', True => 't'); 1187 1188 Orig : constant Node_Id := Original_Node (Cond); 1189 Dummy : Source_Ptr; 1190 Index : Nat; 1191 Start : Source_Ptr; 1192 1193 begin 1194 Sloc_Range (Orig, Start, Dummy); 1195 Index := SCO_Raw_Hash_Table.Get (Start); 1196 1197 -- Index can be zero for boolean expressions that do not have SCOs 1198 -- (simple decisions outside of a control flow structure), or in case 1199 -- of a previous error. 1200 1201 if Index = 0 then 1202 return; 1203 1204 else 1205 pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' '); 1206 SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val); 1207 end if; 1208 end Set_SCO_Condition; 1209 1210 ------------------------------ 1211 -- Set_SCO_Logical_Operator -- 1212 ------------------------------ 1213 1214 procedure Set_SCO_Logical_Operator (Op : Node_Id) is 1215 1216 -- SCO annotations are not processed after the filtering pass 1217 1218 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw); 1219 1220 Orig : constant Node_Id := Original_Node (Op); 1221 Orig_Sloc : constant Source_Ptr := Sloc (Orig); 1222 Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc); 1223 1224 begin 1225 -- All (putative) logical operators are supposed to have their own entry 1226 -- in the SCOs table. However, the semantic analysis may invoke this 1227 -- subprogram with nodes that are out of the SCO generation scope. 1228 1229 if Index /= 0 then 1230 SCO_Raw_Table.Table (Index).C2 := ' '; 1231 end if; 1232 end Set_SCO_Logical_Operator; 1233 1234 ---------------------------- 1235 -- Set_SCO_Pragma_Enabled -- 1236 ---------------------------- 1237 1238 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is 1239 1240 -- SCO annotations are not processed after the filtering pass 1241 1242 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw); 1243 1244 Index : Nat; 1245 1246 begin 1247 -- Nothing to do if not generating SCO, or if we're not processing the 1248 -- original source occurrence of the pragma. 1249 1250 if not (Generate_SCO 1251 and then In_Extended_Main_Source_Unit (Loc) 1252 and then not (In_Instance or In_Inlined_Body)) 1253 then 1254 return; 1255 end if; 1256 1257 -- Note: the reason we use the Sloc value as the key is that in the 1258 -- generic case, the call to this procedure is made on a copy of the 1259 -- original node, so we can't use the Node_Id value. 1260 1261 Index := SCO_Raw_Hash_Table.Get (Loc); 1262 1263 -- A zero index here indicates that semantic analysis found an 1264 -- activated pragma at Loc which does not have a corresponding pragma 1265 -- or aspect at the syntax level. This may occur in legitimate cases 1266 -- because of expanded code (such are Pre/Post conditions generated for 1267 -- formal parameter validity checks), or as a consequence of a previous 1268 -- error. 1269 1270 if Index = 0 then 1271 return; 1272 1273 else 1274 declare 1275 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); 1276 1277 begin 1278 -- Note: may be called multiple times for the same sloc, so 1279 -- account for the fact that the entry may already have been 1280 -- marked enabled. 1281 1282 case T.C1 is 1283 -- Aspect (decision SCO) 1284 1285 when 'a' => 1286 T.C1 := 'A'; 1287 1288 when 'A' => 1289 null; 1290 1291 -- Pragma (statement SCO) 1292 1293 when 'S' => 1294 pragma Assert (T.C2 = 'p' or else T.C2 = 'P'); 1295 T.C2 := 'P'; 1296 1297 when others => 1298 raise Program_Error; 1299 end case; 1300 end; 1301 end if; 1302 end Set_SCO_Pragma_Enabled; 1303 1304 ------------------------- 1305 -- Set_Raw_Table_Entry -- 1306 ------------------------- 1307 1308 procedure Set_Raw_Table_Entry 1309 (C1 : Character; 1310 C2 : Character; 1311 From : Source_Ptr; 1312 To : Source_Ptr; 1313 Last : Boolean; 1314 Pragma_Sloc : Source_Ptr := No_Location; 1315 Pragma_Aspect_Name : Name_Id := No_Name) 1316 is 1317 pragma Assert (SCO_Generation_State = Raw); 1318 begin 1319 SCO_Raw_Table.Append 1320 ((C1 => C1, 1321 C2 => C2, 1322 From => To_Source_Location (From), 1323 To => To_Source_Location (To), 1324 Last => Last, 1325 Pragma_Sloc => Pragma_Sloc, 1326 Pragma_Aspect_Name => Pragma_Aspect_Name)); 1327 end Set_Raw_Table_Entry; 1328 1329 ------------------------ 1330 -- To_Source_Location -- 1331 ------------------------ 1332 1333 function To_Source_Location (S : Source_Ptr) return Source_Location is 1334 begin 1335 if S = No_Location then 1336 return No_Source_Location; 1337 else 1338 return 1339 (Line => Get_Logical_Line_Number (S), 1340 Col => Get_Column_Number (S)); 1341 end if; 1342 end To_Source_Location; 1343 1344 ----------------------------------------- 1345 -- Traverse_Declarations_Or_Statements -- 1346 ----------------------------------------- 1347 1348 -- Tables used by Traverse_Declarations_Or_Statements for temporarily 1349 -- holding statement and decision entries. These are declared globally 1350 -- since they are shared by recursive calls to this procedure. 1351 1352 type SC_Entry is record 1353 N : Node_Id; 1354 From : Source_Ptr; 1355 To : Source_Ptr; 1356 Typ : Character; 1357 end record; 1358 -- Used to store a single entry in the following table, From:To represents 1359 -- the range of entries in the CS line entry, and typ is the type, with 1360 -- space meaning that no type letter will accompany the entry. 1361 1362 package SC is new Table.Table 1363 (Table_Component_Type => SC_Entry, 1364 Table_Index_Type => Nat, 1365 Table_Low_Bound => 1, 1366 Table_Initial => 1000, 1367 Table_Increment => 200, 1368 Table_Name => "SCO_SC"); 1369 -- Used to store statement components for a CS entry to be output as a 1370 -- result of the call to this procedure. SC.Last is the last entry stored, 1371 -- so the current statement sequence is represented by SC_Array (SC_First 1372 -- .. SC.Last), where SC_First is saved on entry to each recursive call to 1373 -- the routine. 1374 -- 1375 -- Extend_Statement_Sequence adds an entry to this array, and then 1376 -- Set_Statement_Entry clears the entries starting with SC_First, copying 1377 -- these entries to the main SCO output table. The reason that we do the 1378 -- temporary caching of results in this array is that we want the SCO table 1379 -- entries for a given CS line to be contiguous, and the processing may 1380 -- output intermediate entries such as decision entries. 1381 1382 type SD_Entry is record 1383 Nod : Node_Id; 1384 Lst : List_Id; 1385 Typ : Character; 1386 Plo : Source_Ptr; 1387 end record; 1388 -- Used to store a single entry in the following table. Nod is the node to 1389 -- be searched for decisions for the case of Process_Decisions_Defer with a 1390 -- node argument (with Lst set to No_List. Lst is the list to be searched 1391 -- for decisions for the case of Process_Decisions_Defer with a List 1392 -- argument (in which case Nod is set to Empty). Plo is the sloc of the 1393 -- enclosing pragma, if any. 1394 1395 package SD is new Table.Table 1396 (Table_Component_Type => SD_Entry, 1397 Table_Index_Type => Nat, 1398 Table_Low_Bound => 1, 1399 Table_Initial => 1000, 1400 Table_Increment => 200, 1401 Table_Name => "SCO_SD"); 1402 -- Used to store possible decision information. Instead of calling the 1403 -- Process_Decisions procedures directly, we call Process_Decisions_Defer, 1404 -- which simply stores the arguments in this table. Then when we clear 1405 -- out a statement sequence using Set_Statement_Entry, after generating 1406 -- the CS lines for the statements, the entries in this table result in 1407 -- calls to Process_Decision. The reason for doing things this way is to 1408 -- ensure that decisions are output after the CS line for the statements 1409 -- in which the decisions occur. 1410 1411 procedure Traverse_Declarations_Or_Statements 1412 (L : List_Id; 1413 D : Dominant_Info := No_Dominant; 1414 P : Node_Id := Empty) 1415 is 1416 Discard_Dom : Dominant_Info; 1417 pragma Warnings (Off, Discard_Dom); 1418 begin 1419 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P); 1420 end Traverse_Declarations_Or_Statements; 1421 1422 function Traverse_Declarations_Or_Statements 1423 (L : List_Id; 1424 D : Dominant_Info := No_Dominant; 1425 P : Node_Id := Empty) return Dominant_Info 1426 is 1427 Current_Dominant : Dominant_Info := D; 1428 -- Dominance information for the current basic block 1429 1430 Current_Test : Node_Id; 1431 -- Conditional node (N_If_Statement or N_Elsif being processed) 1432 1433 N : Node_Id; 1434 1435 SC_First : constant Nat := SC.Last + 1; 1436 SD_First : constant Nat := SD.Last + 1; 1437 -- Record first entries used in SC/SD at this recursive level 1438 1439 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); 1440 -- Extend the current statement sequence to encompass the node N. Typ is 1441 -- the letter that identifies the type of statement/declaration that is 1442 -- being added to the sequence. 1443 1444 procedure Process_Decisions_Defer (N : Node_Id; T : Character); 1445 pragma Inline (Process_Decisions_Defer); 1446 -- This routine is logically the same as Process_Decisions, except that 1447 -- the arguments are saved in the SD table for later processing when 1448 -- Set_Statement_Entry is called, which goes through the saved entries 1449 -- making the corresponding calls to Process_Decision. Note: the 1450 -- enclosing statement must have already been added to the current 1451 -- statement sequence, so that nested decisions are properly 1452 -- identified as such. 1453 1454 procedure Process_Decisions_Defer (L : List_Id; T : Character); 1455 pragma Inline (Process_Decisions_Defer); 1456 -- Same case for list arguments, deferred call to Process_Decisions 1457 1458 procedure Set_Statement_Entry; 1459 -- Output CS entries for all statements saved in table SC, and end the 1460 -- current CS sequence. Then output entries for all decisions nested in 1461 -- these statements, which have been deferred so far. 1462 1463 procedure Traverse_One (N : Node_Id); 1464 -- Traverse one declaration or statement 1465 1466 procedure Traverse_Aspects (N : Node_Id); 1467 -- Helper for Traverse_One: traverse N's aspect specifications 1468 1469 procedure Traverse_Degenerate_Subprogram (N : Node_Id); 1470 -- Common code to handle null procedures and expression functions. Emit 1471 -- a SCO of the given Kind and N outside of the dominance flow. 1472 1473 ------------------------------- 1474 -- Extend_Statement_Sequence -- 1475 ------------------------------- 1476 1477 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is 1478 Dummy : Source_Ptr; 1479 F : Source_Ptr; 1480 T : Source_Ptr; 1481 To_Node : Node_Id := Empty; 1482 1483 begin 1484 Sloc_Range (N, F, T); 1485 1486 case Nkind (N) is 1487 when N_Accept_Statement => 1488 if Present (Parameter_Specifications (N)) then 1489 To_Node := Last (Parameter_Specifications (N)); 1490 elsif Present (Entry_Index (N)) then 1491 To_Node := Entry_Index (N); 1492 else 1493 To_Node := Entry_Direct_Name (N); 1494 end if; 1495 1496 when N_Case_Statement => 1497 To_Node := Expression (N); 1498 1499 when N_Elsif_Part 1500 | N_If_Statement 1501 => 1502 To_Node := Condition (N); 1503 1504 when N_Extended_Return_Statement => 1505 To_Node := Last (Return_Object_Declarations (N)); 1506 1507 when N_Loop_Statement => 1508 To_Node := Iteration_Scheme (N); 1509 1510 when N_Asynchronous_Select 1511 | N_Conditional_Entry_Call 1512 | N_Selective_Accept 1513 | N_Single_Protected_Declaration 1514 | N_Single_Task_Declaration 1515 | N_Timed_Entry_Call 1516 => 1517 T := F; 1518 1519 when N_Protected_Type_Declaration 1520 | N_Task_Type_Declaration 1521 => 1522 if Has_Aspects (N) then 1523 To_Node := Last (Aspect_Specifications (N)); 1524 1525 elsif Present (Discriminant_Specifications (N)) then 1526 To_Node := Last (Discriminant_Specifications (N)); 1527 1528 else 1529 To_Node := Defining_Identifier (N); 1530 end if; 1531 1532 when N_Subexpr => 1533 To_Node := N; 1534 1535 when others => 1536 null; 1537 end case; 1538 1539 if Present (To_Node) then 1540 Sloc_Range (To_Node, Dummy, T); 1541 end if; 1542 1543 SC.Append ((N, F, T, Typ)); 1544 end Extend_Statement_Sequence; 1545 1546 ----------------------------- 1547 -- Process_Decisions_Defer -- 1548 ----------------------------- 1549 1550 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is 1551 begin 1552 SD.Append ((N, No_List, T, Current_Pragma_Sloc)); 1553 end Process_Decisions_Defer; 1554 1555 procedure Process_Decisions_Defer (L : List_Id; T : Character) is 1556 begin 1557 SD.Append ((Empty, L, T, Current_Pragma_Sloc)); 1558 end Process_Decisions_Defer; 1559 1560 ------------------------- 1561 -- Set_Statement_Entry -- 1562 ------------------------- 1563 1564 procedure Set_Statement_Entry is 1565 SC_Last : constant Int := SC.Last; 1566 SD_Last : constant Int := SD.Last; 1567 1568 begin 1569 -- Output statement entries from saved entries in SC table 1570 1571 for J in SC_First .. SC_Last loop 1572 if J = SC_First then 1573 1574 if Current_Dominant /= No_Dominant then 1575 declare 1576 From : Source_Ptr; 1577 To : Source_Ptr; 1578 1579 begin 1580 Sloc_Range (Current_Dominant.N, From, To); 1581 1582 if Current_Dominant.K /= 'E' then 1583 To := No_Location; 1584 end if; 1585 1586 -- Be consistent with the location determined in 1587 -- Output_Header. 1588 1589 if Current_Dominant.K = 'T' 1590 and then Nkind (Parent (Current_Dominant.N)) 1591 in N_Accept_Alternative 1592 | N_Delay_Alternative 1593 | N_Terminate_Alternative 1594 then 1595 From := First_Sloc (Current_Dominant.N); 1596 end if; 1597 1598 Set_Raw_Table_Entry 1599 (C1 => '>', 1600 C2 => Current_Dominant.K, 1601 From => From, 1602 To => To, 1603 Last => False, 1604 Pragma_Sloc => No_Location, 1605 Pragma_Aspect_Name => No_Name); 1606 end; 1607 end if; 1608 end if; 1609 1610 declare 1611 SCE : SC_Entry renames SC.Table (J); 1612 Pragma_Sloc : Source_Ptr := No_Location; 1613 Pragma_Aspect_Name : Name_Id := No_Name; 1614 1615 begin 1616 -- For the case of a statement SCO for a pragma controlled by 1617 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and 1618 -- those of any nested decision) is emitted only if the pragma 1619 -- is enabled. 1620 1621 if SCE.Typ = 'p' then 1622 Pragma_Sloc := SCE.From; 1623 SCO_Raw_Hash_Table.Set 1624 (Pragma_Sloc, SCO_Raw_Table.Last + 1); 1625 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N); 1626 pragma Assert (Pragma_Aspect_Name /= No_Name); 1627 1628 elsif SCE.Typ = 'P' then 1629 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N); 1630 pragma Assert (Pragma_Aspect_Name /= No_Name); 1631 end if; 1632 1633 Set_Raw_Table_Entry 1634 (C1 => 'S', 1635 C2 => SCE.Typ, 1636 From => SCE.From, 1637 To => SCE.To, 1638 Last => (J = SC_Last), 1639 Pragma_Sloc => Pragma_Sloc, 1640 Pragma_Aspect_Name => Pragma_Aspect_Name); 1641 end; 1642 end loop; 1643 1644 -- Last statement of basic block, if present, becomes new current 1645 -- dominant. 1646 1647 if SC_Last >= SC_First then 1648 Current_Dominant := ('S', SC.Table (SC_Last).N); 1649 end if; 1650 1651 -- Clear out used section of SC table 1652 1653 SC.Set_Last (SC_First - 1); 1654 1655 -- Output any embedded decisions 1656 1657 for J in SD_First .. SD_Last loop 1658 declare 1659 SDE : SD_Entry renames SD.Table (J); 1660 1661 begin 1662 if Present (SDE.Nod) then 1663 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); 1664 else 1665 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); 1666 end if; 1667 end; 1668 end loop; 1669 1670 -- Clear out used section of SD table 1671 1672 SD.Set_Last (SD_First - 1); 1673 end Set_Statement_Entry; 1674 1675 ---------------------- 1676 -- Traverse_Aspects -- 1677 ---------------------- 1678 1679 procedure Traverse_Aspects (N : Node_Id) is 1680 AE : Node_Id; 1681 AN : Node_Id; 1682 C1 : Character; 1683 1684 begin 1685 AN := First (Aspect_Specifications (N)); 1686 while Present (AN) loop 1687 AE := Expression (AN); 1688 1689 -- SCOs are generated before semantic analysis/expansion: 1690 -- PPCs are not split yet. 1691 1692 pragma Assert (not Split_PPC (AN)); 1693 1694 C1 := ASCII.NUL; 1695 1696 case Get_Aspect_Id (AN) is 1697 1698 -- Aspects rewritten into pragmas controlled by a Check_Policy: 1699 -- Current_Pragma_Sloc must be set to the sloc of the aspect 1700 -- specification. The corresponding pragma will have the same 1701 -- sloc. Note that Invariant, Pre, and Post will be enabled if 1702 -- the policy is Check; on the other hand, predicate aspects 1703 -- will be enabled for Check and Ignore (when Add_Predicate 1704 -- is called) because the actual checks occur in client units. 1705 -- When the assertion policy for Predicate is Disable, the 1706 -- SCO remains disabled, because Add_Predicate is never called. 1707 1708 -- Pre/post can have checks in client units too because of 1709 -- inheritance, so should they receive the same treatment??? 1710 1711 when Aspect_Dynamic_Predicate 1712 | Aspect_Invariant 1713 | Aspect_Post 1714 | Aspect_Postcondition 1715 | Aspect_Pre 1716 | Aspect_Precondition 1717 | Aspect_Predicate 1718 | Aspect_Static_Predicate 1719 | Aspect_Type_Invariant 1720 => 1721 C1 := 'a'; 1722 1723 -- Other aspects: just process any decision nested in the 1724 -- aspect expression. 1725 1726 when others => 1727 if Has_Decision (AE) then 1728 C1 := 'X'; 1729 end if; 1730 end case; 1731 1732 if C1 /= ASCII.NUL then 1733 pragma Assert (Current_Pragma_Sloc = No_Location); 1734 1735 if C1 = 'a' or else C1 = 'A' then 1736 Current_Pragma_Sloc := Sloc (AN); 1737 end if; 1738 1739 Process_Decisions_Defer (AE, C1); 1740 1741 Current_Pragma_Sloc := No_Location; 1742 end if; 1743 1744 Next (AN); 1745 end loop; 1746 end Traverse_Aspects; 1747 1748 ------------------------------------ 1749 -- Traverse_Degenerate_Subprogram -- 1750 ------------------------------------ 1751 1752 procedure Traverse_Degenerate_Subprogram (N : Node_Id) is 1753 begin 1754 -- Complete current sequence of statements 1755 1756 Set_Statement_Entry; 1757 1758 declare 1759 Saved_Dominant : constant Dominant_Info := Current_Dominant; 1760 -- Save last statement in current sequence as dominant 1761 1762 begin 1763 -- Output statement SCO for degenerate subprogram body (null 1764 -- statement or freestanding expression) outside of the dominance 1765 -- chain. 1766 1767 Current_Dominant := No_Dominant; 1768 Extend_Statement_Sequence (N, Typ => 'X'); 1769 1770 -- For the case of an expression-function, collect decisions 1771 -- embedded in the expression now. 1772 1773 if Nkind (N) in N_Subexpr then 1774 Process_Decisions_Defer (N, 'X'); 1775 end if; 1776 1777 Set_Statement_Entry; 1778 1779 -- Restore current dominant information designating last statement 1780 -- in previous sequence (i.e. make the dominance chain skip over 1781 -- the degenerate body). 1782 1783 Current_Dominant := Saved_Dominant; 1784 end; 1785 end Traverse_Degenerate_Subprogram; 1786 1787 ------------------ 1788 -- Traverse_One -- 1789 ------------------ 1790 1791 procedure Traverse_One (N : Node_Id) is 1792 begin 1793 -- Initialize or extend current statement sequence. Note that for 1794 -- special cases such as IF and Case statements we will modify 1795 -- the range to exclude internal statements that should not be 1796 -- counted as part of the current statement sequence. 1797 1798 case Nkind (N) is 1799 1800 -- Package declaration 1801 1802 when N_Package_Declaration => 1803 Set_Statement_Entry; 1804 Traverse_Package_Declaration (N, Current_Dominant); 1805 1806 -- Generic package declaration 1807 1808 when N_Generic_Package_Declaration => 1809 Set_Statement_Entry; 1810 Traverse_Generic_Package_Declaration (N); 1811 1812 -- Package body 1813 1814 when N_Package_Body => 1815 Set_Statement_Entry; 1816 Traverse_Package_Body (N); 1817 1818 -- Subprogram declaration or subprogram body stub 1819 1820 when N_Expression_Function 1821 | N_Subprogram_Body_Stub 1822 | N_Subprogram_Declaration 1823 => 1824 declare 1825 Spec : constant Node_Id := Specification (N); 1826 begin 1827 Process_Decisions_Defer 1828 (Parameter_Specifications (Spec), 'X'); 1829 1830 -- Case of a null procedure: generate SCO for fictitious 1831 -- NULL statement located at the NULL keyword in the 1832 -- procedure specification. 1833 1834 if Nkind (N) = N_Subprogram_Declaration 1835 and then Nkind (Spec) = N_Procedure_Specification 1836 and then Null_Present (Spec) 1837 then 1838 Traverse_Degenerate_Subprogram (Null_Statement (Spec)); 1839 1840 -- Case of an expression function: generate a statement SCO 1841 -- for the expression (and then decision SCOs for any nested 1842 -- decisions). 1843 1844 elsif Nkind (N) = N_Expression_Function then 1845 Traverse_Degenerate_Subprogram (Expression (N)); 1846 end if; 1847 end; 1848 1849 -- Entry declaration 1850 1851 when N_Entry_Declaration => 1852 Process_Decisions_Defer (Parameter_Specifications (N), 'X'); 1853 1854 -- Generic subprogram declaration 1855 1856 when N_Generic_Subprogram_Declaration => 1857 Process_Decisions_Defer 1858 (Generic_Formal_Declarations (N), 'X'); 1859 Process_Decisions_Defer 1860 (Parameter_Specifications (Specification (N)), 'X'); 1861 1862 -- Task or subprogram body 1863 1864 when N_Subprogram_Body 1865 | N_Task_Body 1866 => 1867 Set_Statement_Entry; 1868 Traverse_Subprogram_Or_Task_Body (N); 1869 1870 -- Entry body 1871 1872 when N_Entry_Body => 1873 declare 1874 Cond : constant Node_Id := 1875 Condition (Entry_Body_Formal_Part (N)); 1876 1877 Inner_Dominant : Dominant_Info := No_Dominant; 1878 1879 begin 1880 Set_Statement_Entry; 1881 1882 if Present (Cond) then 1883 Process_Decisions_Defer (Cond, 'G'); 1884 1885 -- For an entry body with a barrier, the entry body 1886 -- is dominated by a True evaluation of the barrier. 1887 1888 Inner_Dominant := ('T', N); 1889 end if; 1890 1891 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); 1892 end; 1893 1894 -- Protected body 1895 1896 when N_Protected_Body => 1897 Set_Statement_Entry; 1898 Traverse_Declarations_Or_Statements (Declarations (N)); 1899 1900 -- Exit statement, which is an exit statement in the SCO sense, 1901 -- so it is included in the current statement sequence, but 1902 -- then it terminates this sequence. We also have to process 1903 -- any decisions in the exit statement expression. 1904 1905 when N_Exit_Statement => 1906 Extend_Statement_Sequence (N, 'E'); 1907 Process_Decisions_Defer (Condition (N), 'E'); 1908 Set_Statement_Entry; 1909 1910 -- If condition is present, then following statement is 1911 -- only executed if the condition evaluates to False. 1912 1913 if Present (Condition (N)) then 1914 Current_Dominant := ('F', N); 1915 else 1916 Current_Dominant := No_Dominant; 1917 end if; 1918 1919 -- Label, which breaks the current statement sequence, but the 1920 -- label itself is not included in the next statement sequence, 1921 -- since it generates no code. 1922 1923 when N_Label => 1924 Set_Statement_Entry; 1925 Current_Dominant := No_Dominant; 1926 1927 -- Block statement, which breaks the current statement sequence 1928 1929 when N_Block_Statement => 1930 Set_Statement_Entry; 1931 1932 -- The first statement in the handled sequence of statements 1933 -- is dominated by the elaboration of the last declaration. 1934 1935 Current_Dominant := Traverse_Declarations_Or_Statements 1936 (L => Declarations (N), 1937 D => Current_Dominant); 1938 1939 Traverse_Handled_Statement_Sequence 1940 (N => Handled_Statement_Sequence (N), 1941 D => Current_Dominant); 1942 1943 -- If statement, which breaks the current statement sequence, 1944 -- but we include the condition in the current sequence. 1945 1946 when N_If_Statement => 1947 Current_Test := N; 1948 Extend_Statement_Sequence (N, 'I'); 1949 Process_Decisions_Defer (Condition (N), 'I'); 1950 Set_Statement_Entry; 1951 1952 -- Now we traverse the statements in the THEN part 1953 1954 Traverse_Declarations_Or_Statements 1955 (L => Then_Statements (N), 1956 D => ('T', N)); 1957 1958 -- Loop through ELSIF parts if present 1959 1960 if Present (Elsif_Parts (N)) then 1961 declare 1962 Saved_Dominant : constant Dominant_Info := 1963 Current_Dominant; 1964 1965 Elif : Node_Id := First (Elsif_Parts (N)); 1966 1967 begin 1968 while Present (Elif) loop 1969 1970 -- An Elsif is executed only if the previous test 1971 -- got a FALSE outcome. 1972 1973 Current_Dominant := ('F', Current_Test); 1974 1975 -- Now update current test information 1976 1977 Current_Test := Elif; 1978 1979 -- We generate a statement sequence for the 1980 -- construct "ELSIF condition", so that we have 1981 -- a statement for the resulting decisions. 1982 1983 Extend_Statement_Sequence (Elif, 'I'); 1984 Process_Decisions_Defer (Condition (Elif), 'I'); 1985 Set_Statement_Entry; 1986 1987 -- An ELSIF part is never guaranteed to have 1988 -- been executed, following statements are only 1989 -- dominated by the initial IF statement. 1990 1991 Current_Dominant := Saved_Dominant; 1992 1993 -- Traverse the statements in the ELSIF 1994 1995 Traverse_Declarations_Or_Statements 1996 (L => Then_Statements (Elif), 1997 D => ('T', Elif)); 1998 Next (Elif); 1999 end loop; 2000 end; 2001 end if; 2002 2003 -- Finally traverse the ELSE statements if present 2004 2005 Traverse_Declarations_Or_Statements 2006 (L => Else_Statements (N), 2007 D => ('F', Current_Test)); 2008 2009 -- CASE statement, which breaks the current statement sequence, 2010 -- but we include the expression in the current sequence. 2011 2012 when N_Case_Statement => 2013 Extend_Statement_Sequence (N, 'C'); 2014 Process_Decisions_Defer (Expression (N), 'X'); 2015 Set_Statement_Entry; 2016 2017 -- Process case branches, all of which are dominated by the 2018 -- CASE statement. 2019 2020 declare 2021 Alt : Node_Id; 2022 begin 2023 Alt := First_Non_Pragma (Alternatives (N)); 2024 while Present (Alt) loop 2025 Traverse_Declarations_Or_Statements 2026 (L => Statements (Alt), 2027 D => Current_Dominant); 2028 Next (Alt); 2029 end loop; 2030 end; 2031 2032 -- ACCEPT statement 2033 2034 when N_Accept_Statement => 2035 Extend_Statement_Sequence (N, 'A'); 2036 Set_Statement_Entry; 2037 2038 -- Process sequence of statements, dominant is the ACCEPT 2039 -- statement. 2040 2041 Traverse_Handled_Statement_Sequence 2042 (N => Handled_Statement_Sequence (N), 2043 D => Current_Dominant); 2044 2045 -- SELECT 2046 2047 when N_Selective_Accept => 2048 Extend_Statement_Sequence (N, 'S'); 2049 Set_Statement_Entry; 2050 2051 -- Process alternatives 2052 2053 declare 2054 Alt : Node_Id; 2055 Guard : Node_Id; 2056 S_Dom : Dominant_Info; 2057 2058 begin 2059 Alt := First (Select_Alternatives (N)); 2060 while Present (Alt) loop 2061 S_Dom := Current_Dominant; 2062 Guard := Condition (Alt); 2063 2064 if Present (Guard) then 2065 Process_Decisions 2066 (Guard, 2067 'G', 2068 Pragma_Sloc => No_Location); 2069 Current_Dominant := ('T', Guard); 2070 end if; 2071 2072 Traverse_One (Alt); 2073 2074 Current_Dominant := S_Dom; 2075 Next (Alt); 2076 end loop; 2077 end; 2078 2079 Traverse_Declarations_Or_Statements 2080 (L => Else_Statements (N), 2081 D => Current_Dominant); 2082 2083 when N_Conditional_Entry_Call 2084 | N_Timed_Entry_Call 2085 => 2086 Extend_Statement_Sequence (N, 'S'); 2087 Set_Statement_Entry; 2088 2089 -- Process alternatives 2090 2091 Traverse_One (Entry_Call_Alternative (N)); 2092 2093 if Nkind (N) = N_Timed_Entry_Call then 2094 Traverse_One (Delay_Alternative (N)); 2095 else 2096 Traverse_Declarations_Or_Statements 2097 (L => Else_Statements (N), 2098 D => Current_Dominant); 2099 end if; 2100 2101 when N_Asynchronous_Select => 2102 Extend_Statement_Sequence (N, 'S'); 2103 Set_Statement_Entry; 2104 2105 Traverse_One (Triggering_Alternative (N)); 2106 Traverse_Declarations_Or_Statements 2107 (L => Statements (Abortable_Part (N)), 2108 D => Current_Dominant); 2109 2110 when N_Accept_Alternative => 2111 Traverse_Declarations_Or_Statements 2112 (L => Statements (N), 2113 D => Current_Dominant, 2114 P => Accept_Statement (N)); 2115 2116 when N_Entry_Call_Alternative => 2117 Traverse_Declarations_Or_Statements 2118 (L => Statements (N), 2119 D => Current_Dominant, 2120 P => Entry_Call_Statement (N)); 2121 2122 when N_Delay_Alternative => 2123 Traverse_Declarations_Or_Statements 2124 (L => Statements (N), 2125 D => Current_Dominant, 2126 P => Delay_Statement (N)); 2127 2128 when N_Triggering_Alternative => 2129 Traverse_Declarations_Or_Statements 2130 (L => Statements (N), 2131 D => Current_Dominant, 2132 P => Triggering_Statement (N)); 2133 2134 when N_Terminate_Alternative => 2135 2136 -- It is dubious to emit a statement SCO for a TERMINATE 2137 -- alternative, since no code is actually executed if the 2138 -- alternative is selected -- the tasking runtime call just 2139 -- never returns??? 2140 2141 Extend_Statement_Sequence (N, ' '); 2142 Set_Statement_Entry; 2143 2144 -- Unconditional exit points, which are included in the current 2145 -- statement sequence, but then terminate it 2146 2147 when N_Goto_Statement 2148 | N_Raise_Statement 2149 | N_Requeue_Statement 2150 => 2151 Extend_Statement_Sequence (N, ' '); 2152 Set_Statement_Entry; 2153 Current_Dominant := No_Dominant; 2154 2155 -- Simple return statement. which is an exit point, but we 2156 -- have to process the return expression for decisions. 2157 2158 when N_Simple_Return_Statement => 2159 Extend_Statement_Sequence (N, ' '); 2160 Process_Decisions_Defer (Expression (N), 'X'); 2161 Set_Statement_Entry; 2162 Current_Dominant := No_Dominant; 2163 2164 -- Extended return statement 2165 2166 when N_Extended_Return_Statement => 2167 Extend_Statement_Sequence (N, 'R'); 2168 Process_Decisions_Defer (Return_Object_Declarations (N), 'X'); 2169 Set_Statement_Entry; 2170 2171 Traverse_Handled_Statement_Sequence 2172 (N => Handled_Statement_Sequence (N), 2173 D => Current_Dominant); 2174 2175 Current_Dominant := No_Dominant; 2176 2177 -- Loop ends the current statement sequence, but we include 2178 -- the iteration scheme if present in the current sequence. 2179 -- But the body of the loop starts a new sequence, since it 2180 -- may not be executed as part of the current sequence. 2181 2182 when N_Loop_Statement => 2183 declare 2184 ISC : constant Node_Id := Iteration_Scheme (N); 2185 Inner_Dominant : Dominant_Info := No_Dominant; 2186 2187 begin 2188 if Present (ISC) then 2189 2190 -- If iteration scheme present, extend the current 2191 -- statement sequence to include the iteration scheme 2192 -- and process any decisions it contains. 2193 2194 -- While loop 2195 2196 if Present (Condition (ISC)) then 2197 Extend_Statement_Sequence (N, 'W'); 2198 Process_Decisions_Defer (Condition (ISC), 'W'); 2199 2200 -- Set more specific dominant for inner statements 2201 -- (the control sloc for the decision is that of 2202 -- the WHILE token). 2203 2204 Inner_Dominant := ('T', ISC); 2205 2206 -- For loop 2207 2208 else 2209 Extend_Statement_Sequence (N, 'F'); 2210 Process_Decisions_Defer 2211 (Loop_Parameter_Specification (ISC), 'X'); 2212 end if; 2213 end if; 2214 2215 Set_Statement_Entry; 2216 2217 if Inner_Dominant = No_Dominant then 2218 Inner_Dominant := Current_Dominant; 2219 end if; 2220 2221 Traverse_Declarations_Or_Statements 2222 (L => Statements (N), 2223 D => Inner_Dominant); 2224 end; 2225 2226 -- Pragma 2227 2228 when N_Pragma => 2229 2230 -- Record sloc of pragma (pragmas don't nest) 2231 2232 pragma Assert (Current_Pragma_Sloc = No_Location); 2233 Current_Pragma_Sloc := Sloc (N); 2234 2235 -- Processing depends on the kind of pragma 2236 2237 declare 2238 Nam : constant Name_Id := Pragma_Name_Unmapped (N); 2239 Arg : Node_Id := 2240 First (Pragma_Argument_Associations (N)); 2241 Typ : Character; 2242 2243 begin 2244 case Nam is 2245 when Name_Assert 2246 | Name_Assert_And_Cut 2247 | Name_Assume 2248 | Name_Check 2249 | Name_Loop_Invariant 2250 | Name_Postcondition 2251 | Name_Precondition 2252 | Name_Type_Invariant 2253 | Name_Invariant 2254 => 2255 -- For Assert/Check/Precondition/Postcondition, we 2256 -- must generate a P entry for the decision. Note 2257 -- that this is done unconditionally at this stage. 2258 -- Output for disabled pragmas is suppressed later 2259 -- on when we output the decision line in Put_SCOs, 2260 -- depending on setting by Set_SCO_Pragma_Enabled. 2261 2262 if Nam = Name_Check 2263 or else Nam = Name_Type_Invariant 2264 or else Nam = Name_Invariant 2265 then 2266 Next (Arg); 2267 end if; 2268 2269 Process_Decisions_Defer (Expression (Arg), 'P'); 2270 Typ := 'p'; 2271 2272 -- Pre/postconditions can be inherited so SCO should 2273 -- never be deactivated??? 2274 2275 when Name_Debug => 2276 if Present (Arg) and then Present (Next (Arg)) then 2277 2278 -- Case of a dyadic pragma Debug: first argument 2279 -- is a P decision, any nested decision in the 2280 -- second argument is an X decision. 2281 2282 Process_Decisions_Defer (Expression (Arg), 'P'); 2283 Next (Arg); 2284 end if; 2285 2286 Process_Decisions_Defer (Expression (Arg), 'X'); 2287 Typ := 'p'; 2288 2289 -- For all other pragmas, we generate decision entries 2290 -- for any embedded expressions, and the pragma is 2291 -- never disabled. 2292 2293 -- Should generate P decisions (not X) for assertion 2294 -- related pragmas: [{Static,Dynamic}_]Predicate??? 2295 2296 when others => 2297 Process_Decisions_Defer (N, 'X'); 2298 Typ := 'P'; 2299 end case; 2300 2301 -- Add statement SCO 2302 2303 Extend_Statement_Sequence (N, Typ); 2304 2305 Current_Pragma_Sloc := No_Location; 2306 end; 2307 2308 -- Object declaration. Ignored if Prev_Ids is set, since the 2309 -- parser generates multiple instances of the whole declaration 2310 -- if there is more than one identifier declared, and we only 2311 -- want one entry in the SCOs, so we take the first, for which 2312 -- Prev_Ids is False. 2313 2314 when N_Number_Declaration 2315 | N_Object_Declaration 2316 => 2317 if not Prev_Ids (N) then 2318 Extend_Statement_Sequence (N, 'o'); 2319 2320 if Has_Decision (N) then 2321 Process_Decisions_Defer (N, 'X'); 2322 end if; 2323 end if; 2324 2325 -- All other cases, which extend the current statement sequence 2326 -- but do not terminate it, even if they have nested decisions. 2327 2328 when N_Protected_Type_Declaration 2329 | N_Task_Type_Declaration 2330 => 2331 Extend_Statement_Sequence (N, 't'); 2332 Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); 2333 Set_Statement_Entry; 2334 2335 Traverse_Protected_Or_Task_Definition (N); 2336 2337 when N_Single_Protected_Declaration 2338 | N_Single_Task_Declaration 2339 => 2340 Extend_Statement_Sequence (N, 'o'); 2341 Set_Statement_Entry; 2342 2343 Traverse_Protected_Or_Task_Definition (N); 2344 2345 when others => 2346 2347 -- Determine required type character code, or ASCII.NUL if 2348 -- no SCO should be generated for this node. 2349 2350 declare 2351 NK : constant Node_Kind := Nkind (N); 2352 Typ : Character; 2353 2354 begin 2355 case NK is 2356 when N_Full_Type_Declaration 2357 | N_Incomplete_Type_Declaration 2358 | N_Private_Extension_Declaration 2359 | N_Private_Type_Declaration 2360 => 2361 Typ := 't'; 2362 2363 when N_Subtype_Declaration => 2364 Typ := 's'; 2365 2366 when N_Renaming_Declaration => 2367 Typ := 'r'; 2368 2369 when N_Generic_Instantiation => 2370 Typ := 'i'; 2371 2372 when N_Package_Body_Stub 2373 | N_Protected_Body_Stub 2374 | N_Representation_Clause 2375 | N_Task_Body_Stub 2376 | N_Use_Package_Clause 2377 | N_Use_Type_Clause 2378 => 2379 Typ := ASCII.NUL; 2380 2381 when N_Procedure_Call_Statement => 2382 Typ := ' '; 2383 2384 when others => 2385 if NK in N_Statement_Other_Than_Procedure_Call then 2386 Typ := ' '; 2387 else 2388 Typ := 'd'; 2389 end if; 2390 end case; 2391 2392 if Typ /= ASCII.NUL then 2393 Extend_Statement_Sequence (N, Typ); 2394 end if; 2395 end; 2396 2397 -- Process any embedded decisions 2398 2399 if Has_Decision (N) then 2400 Process_Decisions_Defer (N, 'X'); 2401 end if; 2402 end case; 2403 2404 -- Process aspects if present 2405 2406 Traverse_Aspects (N); 2407 end Traverse_One; 2408 2409 -- Start of processing for Traverse_Declarations_Or_Statements 2410 2411 begin 2412 -- Process single prefixed node 2413 2414 if Present (P) then 2415 Traverse_One (P); 2416 end if; 2417 2418 -- Loop through statements or declarations 2419 2420 if Is_Non_Empty_List (L) then 2421 N := First (L); 2422 while Present (N) loop 2423 2424 -- Note: For separate bodies, we see the tree after Par.Labl has 2425 -- introduced implicit labels, so we need to ignore those nodes. 2426 2427 if Nkind (N) /= N_Implicit_Label_Declaration then 2428 Traverse_One (N); 2429 end if; 2430 2431 Next (N); 2432 end loop; 2433 2434 end if; 2435 2436 -- End sequence of statements and flush deferred decisions 2437 2438 if Present (P) or else Is_Non_Empty_List (L) then 2439 Set_Statement_Entry; 2440 end if; 2441 2442 return Current_Dominant; 2443 end Traverse_Declarations_Or_Statements; 2444 2445 ------------------------------------------ 2446 -- Traverse_Generic_Package_Declaration -- 2447 ------------------------------------------ 2448 2449 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is 2450 begin 2451 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); 2452 Traverse_Package_Declaration (N); 2453 end Traverse_Generic_Package_Declaration; 2454 2455 ----------------------------------------- 2456 -- Traverse_Handled_Statement_Sequence -- 2457 ----------------------------------------- 2458 2459 procedure Traverse_Handled_Statement_Sequence 2460 (N : Node_Id; 2461 D : Dominant_Info := No_Dominant) 2462 is 2463 Handler : Node_Id; 2464 2465 begin 2466 -- For package bodies without a statement part, the parser adds an empty 2467 -- one, to normalize the representation. The null statement therein, 2468 -- which does not come from source, does not get a SCO. 2469 2470 if Present (N) and then Comes_From_Source (N) then 2471 Traverse_Declarations_Or_Statements (Statements (N), D); 2472 2473 if Present (Exception_Handlers (N)) then 2474 Handler := First_Non_Pragma (Exception_Handlers (N)); 2475 while Present (Handler) loop 2476 Traverse_Declarations_Or_Statements 2477 (L => Statements (Handler), 2478 D => ('E', Handler)); 2479 Next (Handler); 2480 end loop; 2481 end if; 2482 end if; 2483 end Traverse_Handled_Statement_Sequence; 2484 2485 --------------------------- 2486 -- Traverse_Package_Body -- 2487 --------------------------- 2488 2489 procedure Traverse_Package_Body (N : Node_Id) is 2490 Dom : Dominant_Info; 2491 begin 2492 -- The first statement in the handled sequence of statements is 2493 -- dominated by the elaboration of the last declaration. 2494 2495 Dom := Traverse_Declarations_Or_Statements (Declarations (N)); 2496 2497 Traverse_Handled_Statement_Sequence 2498 (Handled_Statement_Sequence (N), Dom); 2499 end Traverse_Package_Body; 2500 2501 ---------------------------------- 2502 -- Traverse_Package_Declaration -- 2503 ---------------------------------- 2504 2505 procedure Traverse_Package_Declaration 2506 (N : Node_Id; 2507 D : Dominant_Info := No_Dominant) 2508 is 2509 Spec : constant Node_Id := Specification (N); 2510 Dom : Dominant_Info; 2511 2512 begin 2513 Dom := 2514 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D); 2515 2516 -- First private declaration is dominated by last visible declaration 2517 2518 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); 2519 end Traverse_Package_Declaration; 2520 2521 ------------------------------------------- 2522 -- Traverse_Protected_Or_Task_Definition -- 2523 ------------------------------------------- 2524 2525 procedure Traverse_Protected_Or_Task_Definition (N : Node_Id) is 2526 Dom_Info : Dominant_Info := ('S', N); 2527 -- The first declaration is dominated by the protected or task [type] 2528 -- declaration. 2529 2530 Sync_Def : Node_Id; 2531 -- N's protected or task definition 2532 2533 Priv_Decl : List_Id; 2534 Vis_Decl : List_Id; 2535 -- Sync_Def's Visible_Declarations and Private_Declarations 2536 2537 begin 2538 case Nkind (N) is 2539 when N_Protected_Type_Declaration 2540 | N_Single_Protected_Declaration 2541 => 2542 Sync_Def := Protected_Definition (N); 2543 2544 when N_Single_Task_Declaration 2545 | N_Task_Type_Declaration 2546 => 2547 Sync_Def := Task_Definition (N); 2548 2549 when others => 2550 raise Program_Error; 2551 end case; 2552 2553 -- Sync_Def may be Empty at least for empty Task_Type_Declarations. 2554 -- Querying Visible or Private_Declarations is invalid in this case. 2555 2556 if Present (Sync_Def) then 2557 Vis_Decl := Visible_Declarations (Sync_Def); 2558 Priv_Decl := Private_Declarations (Sync_Def); 2559 else 2560 Vis_Decl := No_List; 2561 Priv_Decl := No_List; 2562 end if; 2563 2564 Dom_Info := Traverse_Declarations_Or_Statements 2565 (L => Vis_Decl, 2566 D => Dom_Info); 2567 2568 -- If visible declarations are present, the first private declaration 2569 -- is dominated by the last visible declaration. 2570 2571 Traverse_Declarations_Or_Statements 2572 (L => Priv_Decl, 2573 D => Dom_Info); 2574 end Traverse_Protected_Or_Task_Definition; 2575 2576 -------------------------------------- 2577 -- Traverse_Subprogram_Or_Task_Body -- 2578 -------------------------------------- 2579 2580 procedure Traverse_Subprogram_Or_Task_Body 2581 (N : Node_Id; 2582 D : Dominant_Info := No_Dominant) 2583 is 2584 Decls : constant List_Id := Declarations (N); 2585 Dom_Info : Dominant_Info := D; 2586 2587 begin 2588 -- If declarations are present, the first statement is dominated by the 2589 -- last declaration. 2590 2591 Dom_Info := Traverse_Declarations_Or_Statements 2592 (L => Decls, D => Dom_Info); 2593 2594 Traverse_Handled_Statement_Sequence 2595 (N => Handled_Statement_Sequence (N), 2596 D => Dom_Info); 2597 end Traverse_Subprogram_Or_Task_Body; 2598 2599 ------------------------- 2600 -- SCO_Record_Filtered -- 2601 ------------------------- 2602 2603 procedure SCO_Record_Filtered is 2604 type Decision is record 2605 Kind : Character; 2606 -- Type of the SCO decision (see comments for SCO_Table_Entry.C1) 2607 2608 Sloc : Source_Location; 2609 2610 Top : Nat; 2611 -- Index in the SCO_Raw_Table for the root operator/condition for the 2612 -- expression that controls the decision. 2613 end record; 2614 -- Decision descriptor: used to gather information about a candidate 2615 -- SCO decision. 2616 2617 package Pending_Decisions is new Table.Table 2618 (Table_Component_Type => Decision, 2619 Table_Index_Type => Nat, 2620 Table_Low_Bound => 1, 2621 Table_Initial => 1000, 2622 Table_Increment => 200, 2623 Table_Name => "Filter_Pending_Decisions"); 2624 -- Table used to hold decisions to process during the collection pass 2625 2626 procedure Add_Expression_Tree (Idx : in out Nat); 2627 -- Add SCO raw table entries for the decision controlling expression 2628 -- tree starting at Idx to the filtered SCO table. 2629 2630 procedure Collect_Decisions 2631 (D : Decision; 2632 Next : out Nat); 2633 -- Collect decisions to add to the filtered SCO table starting at the 2634 -- D decision (including it and its nested operators/conditions). Set 2635 -- Next to the first node index passed the whole decision. 2636 2637 procedure Compute_Range 2638 (Idx : in out Nat; 2639 From : out Source_Location; 2640 To : out Source_Location); 2641 -- Compute the source location range for the expression tree starting at 2642 -- Idx in the SCO raw table. Store its bounds in From and To. 2643 2644 function Is_Decision (Idx : Nat) return Boolean; 2645 -- Return if the expression tree starting at Idx has adjacent nested 2646 -- nodes that make a decision. 2647 2648 procedure Process_Pending_Decisions 2649 (Original_Decision : SCO_Table_Entry); 2650 -- Complete the filtered SCO table using collected decisions. Output 2651 -- decisions inherit the pragma information from the original decision. 2652 2653 procedure Search_Nested_Decisions (Idx : in out Nat); 2654 -- Collect decisions to add to the filtered SCO table starting at the 2655 -- node at Idx in the SCO raw table. This node must not be part of an 2656 -- already-processed decision. Set Idx to the first node index passed 2657 -- the whole expression tree. 2658 2659 procedure Skip_Decision 2660 (Idx : in out Nat; 2661 Process_Nested_Decisions : Boolean); 2662 -- Skip all the nodes that belong to the decision starting at Idx. If 2663 -- Process_Nested_Decision, call Search_Nested_Decisions on the first 2664 -- nested nodes that do not belong to the decision. Set Idx to the first 2665 -- node index passed the whole expression tree. 2666 2667 ------------------------- 2668 -- Add_Expression_Tree -- 2669 ------------------------- 2670 2671 procedure Add_Expression_Tree (Idx : in out Nat) is 2672 Node_Idx : constant Nat := Idx; 2673 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx); 2674 From : Source_Location; 2675 To : Source_Location; 2676 2677 begin 2678 case T.C1 is 2679 when ' ' => 2680 2681 -- This is a single condition. Add an entry for it and move on 2682 2683 SCO_Table.Append (T); 2684 Idx := Idx + 1; 2685 2686 when '!' => 2687 2688 -- This is a NOT operator: add an entry for it and browse its 2689 -- only child. 2690 2691 SCO_Table.Append (T); 2692 Idx := Idx + 1; 2693 Add_Expression_Tree (Idx); 2694 2695 when others => 2696 2697 -- This must be an AND/OR/AND THEN/OR ELSE operator 2698 2699 if T.C2 = '?' then 2700 2701 -- This is not a short circuit operator: consider this one 2702 -- and all its children as a single condition. 2703 2704 Compute_Range (Idx, From, To); 2705 SCO_Table.Append 2706 ((From => From, 2707 To => To, 2708 C1 => ' ', 2709 C2 => 'c', 2710 Last => False, 2711 Pragma_Sloc => No_Location, 2712 Pragma_Aspect_Name => No_Name)); 2713 2714 else 2715 -- This is a real short circuit operator: add an entry for 2716 -- it and browse its children. 2717 2718 SCO_Table.Append (T); 2719 Idx := Idx + 1; 2720 Add_Expression_Tree (Idx); 2721 Add_Expression_Tree (Idx); 2722 end if; 2723 end case; 2724 end Add_Expression_Tree; 2725 2726 ----------------------- 2727 -- Collect_Decisions -- 2728 ----------------------- 2729 2730 procedure Collect_Decisions 2731 (D : Decision; 2732 Next : out Nat) 2733 is 2734 Idx : Nat := D.Top; 2735 2736 begin 2737 if D.Kind /= 'X' or else Is_Decision (D.Top) then 2738 Pending_Decisions.Append (D); 2739 end if; 2740 2741 Skip_Decision (Idx, True); 2742 Next := Idx; 2743 end Collect_Decisions; 2744 2745 ------------------- 2746 -- Compute_Range -- 2747 ------------------- 2748 2749 procedure Compute_Range 2750 (Idx : in out Nat; 2751 From : out Source_Location; 2752 To : out Source_Location) 2753 is 2754 Sloc_F : Source_Location := No_Source_Location; 2755 Sloc_T : Source_Location := No_Source_Location; 2756 2757 procedure Process_One; 2758 -- Process one node of the tree, and recurse over children. Update 2759 -- Idx during the traversal. 2760 2761 ----------------- 2762 -- Process_One -- 2763 ----------------- 2764 2765 procedure Process_One is 2766 begin 2767 if Sloc_F = No_Source_Location 2768 or else 2769 SCO_Raw_Table.Table (Idx).From < Sloc_F 2770 then 2771 Sloc_F := SCO_Raw_Table.Table (Idx).From; 2772 end if; 2773 2774 if Sloc_T = No_Source_Location 2775 or else 2776 Sloc_T < SCO_Raw_Table.Table (Idx).To 2777 then 2778 Sloc_T := SCO_Raw_Table.Table (Idx).To; 2779 end if; 2780 2781 if SCO_Raw_Table.Table (Idx).C1 = ' ' then 2782 2783 -- This is a condition: nothing special to do 2784 2785 Idx := Idx + 1; 2786 2787 elsif SCO_Raw_Table.Table (Idx).C1 = '!' then 2788 2789 -- The "not" operator has only one operand 2790 2791 Idx := Idx + 1; 2792 Process_One; 2793 2794 else 2795 -- This is an AND THEN or OR ELSE logical operator: follow the 2796 -- left, then the right operands. 2797 2798 Idx := Idx + 1; 2799 2800 Process_One; 2801 Process_One; 2802 end if; 2803 end Process_One; 2804 2805 -- Start of processing for Compute_Range 2806 2807 begin 2808 Process_One; 2809 From := Sloc_F; 2810 To := Sloc_T; 2811 end Compute_Range; 2812 2813 ----------------- 2814 -- Is_Decision -- 2815 ----------------- 2816 2817 function Is_Decision (Idx : Nat) return Boolean is 2818 Index : Nat := Idx; 2819 2820 begin 2821 loop 2822 declare 2823 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); 2824 2825 begin 2826 case T.C1 is 2827 when ' ' => 2828 return False; 2829 2830 when '!' => 2831 2832 -- This is a decision iff the only operand of the NOT 2833 -- operator could be a standalone decision. 2834 2835 Index := Idx + 1; 2836 2837 when others => 2838 2839 -- This node is a logical operator (and thus could be a 2840 -- standalone decision) iff it is a short circuit 2841 -- operator. 2842 2843 return T.C2 /= '?'; 2844 end case; 2845 end; 2846 end loop; 2847 end Is_Decision; 2848 2849 ------------------------------- 2850 -- Process_Pending_Decisions -- 2851 ------------------------------- 2852 2853 procedure Process_Pending_Decisions 2854 (Original_Decision : SCO_Table_Entry) 2855 is 2856 begin 2857 for Index in 1 .. Pending_Decisions.Last loop 2858 declare 2859 D : Decision renames Pending_Decisions.Table (Index); 2860 Idx : Nat := D.Top; 2861 2862 begin 2863 -- Add a SCO table entry for the decision itself 2864 2865 pragma Assert (D.Kind /= ' '); 2866 2867 SCO_Table.Append 2868 ((To => No_Source_Location, 2869 From => D.Sloc, 2870 C1 => D.Kind, 2871 C2 => ' ', 2872 Last => False, 2873 Pragma_Sloc => Original_Decision.Pragma_Sloc, 2874 Pragma_Aspect_Name => 2875 Original_Decision.Pragma_Aspect_Name)); 2876 2877 -- Then add ones for its nested operators/operands. Do not 2878 -- forget to tag its *last* entry as such. 2879 2880 Add_Expression_Tree (Idx); 2881 SCO_Table.Table (SCO_Table.Last).Last := True; 2882 end; 2883 end loop; 2884 2885 -- Clear the pending decisions list 2886 Pending_Decisions.Set_Last (0); 2887 end Process_Pending_Decisions; 2888 2889 ----------------------------- 2890 -- Search_Nested_Decisions -- 2891 ----------------------------- 2892 2893 procedure Search_Nested_Decisions (Idx : in out Nat) is 2894 begin 2895 loop 2896 declare 2897 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx); 2898 2899 begin 2900 case T.C1 is 2901 when ' ' => 2902 Idx := Idx + 1; 2903 exit; 2904 2905 when '!' => 2906 Collect_Decisions 2907 ((Kind => 'X', 2908 Sloc => T.From, 2909 Top => Idx), 2910 Idx); 2911 exit; 2912 2913 when others => 2914 if T.C2 = '?' then 2915 2916 -- This is not a logical operator: start looking for 2917 -- nested decisions from here. Recurse over the left 2918 -- child and let the loop take care of the right one. 2919 2920 Idx := Idx + 1; 2921 Search_Nested_Decisions (Idx); 2922 2923 else 2924 -- We found a nested decision 2925 2926 Collect_Decisions 2927 ((Kind => 'X', 2928 Sloc => T.From, 2929 Top => Idx), 2930 Idx); 2931 exit; 2932 end if; 2933 end case; 2934 end; 2935 end loop; 2936 end Search_Nested_Decisions; 2937 2938 ------------------- 2939 -- Skip_Decision -- 2940 ------------------- 2941 2942 procedure Skip_Decision 2943 (Idx : in out Nat; 2944 Process_Nested_Decisions : Boolean) 2945 is 2946 begin 2947 loop 2948 declare 2949 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx); 2950 2951 begin 2952 Idx := Idx + 1; 2953 2954 case T.C1 is 2955 when ' ' => 2956 exit; 2957 2958 when '!' => 2959 2960 -- This NOT operator belongs to the outside decision: 2961 -- just skip it. 2962 2963 null; 2964 2965 when others => 2966 if T.C2 = '?' and then Process_Nested_Decisions then 2967 2968 -- This is not a logical operator: start looking for 2969 -- nested decisions from here. Recurse over the left 2970 -- child and let the loop take care of the right one. 2971 2972 Search_Nested_Decisions (Idx); 2973 2974 else 2975 -- This is a logical operator, so it belongs to the 2976 -- outside decision: skip its left child, then let the 2977 -- loop take care of the right one. 2978 2979 Skip_Decision (Idx, Process_Nested_Decisions); 2980 end if; 2981 end case; 2982 end; 2983 end loop; 2984 end Skip_Decision; 2985 2986 -- Start of processing for SCO_Record_Filtered 2987 2988 begin 2989 -- Filtering must happen only once: do nothing if it this pass was 2990 -- already run. 2991 2992 if SCO_Generation_State = Filtered then 2993 return; 2994 else 2995 pragma Assert (SCO_Generation_State = Raw); 2996 SCO_Generation_State := Filtered; 2997 end if; 2998 2999 -- Loop through all SCO entries under SCO units 3000 3001 for Unit_Idx in 1 .. SCO_Unit_Table.Last loop 3002 declare 3003 Unit : SCO_Unit_Table_Entry 3004 renames SCO_Unit_Table.Table (Unit_Idx); 3005 3006 Idx : Nat := Unit.From; 3007 -- Index of the current SCO raw table entry 3008 3009 New_From : constant Nat := SCO_Table.Last + 1; 3010 -- After copying SCO enties of interest to the final table, we 3011 -- will have to change the From/To indexes this unit targets. 3012 -- This constant keeps track of the new From index. 3013 3014 begin 3015 while Idx <= Unit.To loop 3016 declare 3017 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx); 3018 3019 begin 3020 case T.C1 is 3021 3022 -- Decision (of any kind, including pragmas and aspects) 3023 3024 when 'E' | 'G' | 'I' | 'W' | 'X' | 'P' | 'a' | 'A' => 3025 if SCO_Pragma_Disabled (T.Pragma_Sloc) then 3026 3027 -- Skip SCO entries for decisions in disabled 3028 -- constructs (pragmas or aspects). 3029 3030 Idx := Idx + 1; 3031 Skip_Decision (Idx, False); 3032 3033 else 3034 Collect_Decisions 3035 ((Kind => T.C1, 3036 Sloc => T.From, 3037 Top => Idx + 1), 3038 Idx); 3039 Process_Pending_Decisions (T); 3040 end if; 3041 3042 -- There is no translation/filtering to do for other kind 3043 -- of SCO items (statements, dominance markers, etc.). 3044 3045 when '|' | '&' | '!' | ' ' => 3046 3047 -- SCO logical operators and conditions cannot exist 3048 -- on their own: they must be inside a decision (such 3049 -- entries must have been skipped by 3050 -- Collect_Decisions). 3051 3052 raise Program_Error; 3053 3054 when others => 3055 SCO_Table.Append (T); 3056 Idx := Idx + 1; 3057 end case; 3058 end; 3059 end loop; 3060 3061 -- Now, update the SCO entry indexes in the unit entry 3062 3063 Unit.From := New_From; 3064 Unit.To := SCO_Table.Last; 3065 end; 3066 end loop; 3067 3068 -- Then clear the raw table to free bytes 3069 3070 SCO_Raw_Table.Free; 3071 end SCO_Record_Filtered; 3072 3073end Par_SCO; 3074