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