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