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-2013, 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 -- Unit Number Table -- 52 ----------------------- 53 54 -- This table parallels the SCO_Unit_Table, keeping track of the unit 55 -- numbers corresponding to the entries made in this table, so that before 56 -- writing out the SCO information to the ALI file, we can fill in the 57 -- proper dependency numbers and file names. 58 59 -- Note that the zero'th entry is here for convenience in sorting the 60 -- table, the real lower bound is 1. 61 62 package SCO_Unit_Number_Table is new Table.Table ( 63 Table_Component_Type => Unit_Number_Type, 64 Table_Index_Type => SCO_Unit_Index, 65 Table_Low_Bound => 0, -- see note above on sort 66 Table_Initial => 20, 67 Table_Increment => 200, 68 Table_Name => "SCO_Unit_Number_Entry"); 69 70 --------------------------------- 71 -- Condition/Pragma Hash Table -- 72 --------------------------------- 73 74 -- We need to be able to get to conditions quickly for handling the calls 75 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to 76 -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the 77 -- conditions and pragmas in the table by their starting sloc, and use this 78 -- hash table to map from these sloc values to SCO_Table indexes. 79 80 type Header_Num is new Integer range 0 .. 996; 81 -- Type for hash table headers 82 83 function Hash (F : Source_Ptr) return Header_Num; 84 -- Function to Hash source pointer value 85 86 function Equal (F1, F2 : Source_Ptr) return Boolean; 87 -- Function to test two keys for equality 88 89 package Condition_Pragma_Hash_Table is new Simple_HTable 90 (Header_Num, Int, 0, Source_Ptr, Hash, Equal); 91 -- The actual hash table 92 93 -------------------------- 94 -- Internal Subprograms -- 95 -------------------------- 96 97 function Has_Decision (N : Node_Id) return Boolean; 98 -- N is the node for a subexpression. Returns True if the subexpression 99 -- contains a nested decision (i.e. either is a logical operator, or 100 -- contains a logical operator in its subtree). 101 102 function Is_Logical_Operator (N : Node_Id) return Boolean; 103 -- N is the node for a subexpression. This procedure just tests N to see 104 -- if it is a logical operator (including short circuit conditions, but 105 -- excluding OR and AND) and returns True if so, False otherwise, it does 106 -- no other processing. 107 108 function To_Source_Location (S : Source_Ptr) return Source_Location; 109 -- Converts Source_Ptr value to Source_Location (line/col) format 110 111 procedure Process_Decisions 112 (N : Node_Id; 113 T : Character; 114 Pragma_Sloc : Source_Ptr); 115 -- If N is Empty, has no effect. Otherwise scans the tree for the node N, 116 -- to output any decisions it contains. T is one of IEGPWX (for context of 117 -- expression: if/exit when/entry guard/pragma/while/expression). If T is 118 -- other than X, the node N is the if expression involved, and a decision 119 -- is always present (at the very least a simple decision is present at the 120 -- top level). 121 122 procedure Process_Decisions 123 (L : List_Id; 124 T : Character; 125 Pragma_Sloc : Source_Ptr); 126 -- Calls above procedure for each element of the list L 127 128 procedure Set_Table_Entry 129 (C1 : Character; 130 C2 : Character; 131 From : Source_Ptr; 132 To : Source_Ptr; 133 Last : Boolean; 134 Pragma_Sloc : Source_Ptr := No_Location; 135 Pragma_Aspect_Name : Name_Id := No_Name); 136 -- Append an entry to SCO_Table with fields set as per arguments 137 138 type Dominant_Info is record 139 K : Character; 140 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant 141 142 N : Node_Id; 143 -- Node providing the Sloc(s) for the dominance marker 144 end record; 145 No_Dominant : constant Dominant_Info := (' ', Empty); 146 147 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr); 148 -- Add one entry from the instance table to the corresponding SCO table 149 150 procedure Traverse_Declarations_Or_Statements 151 (L : List_Id; 152 D : Dominant_Info := No_Dominant; 153 P : Node_Id := Empty); 154 -- Process L, a list of statements or declarations dominated by D. 155 -- If P is present, it is processed as though it had been prepended to L. 156 157 function Traverse_Declarations_Or_Statements 158 (L : List_Id; 159 D : Dominant_Info := No_Dominant; 160 P : Node_Id := Empty) return Dominant_Info; 161 -- Same as above, and returns dominant information corresponding to the 162 -- last node with SCO in L. 163 164 -- The following Traverse_* routines perform appropriate calls to 165 -- Traverse_Declarations_Or_Statements to traverse specific node kinds. 166 -- Parameter D, when present, indicates the dominant of the first 167 -- declaration or statement within N. 168 169 -- Why is Traverse_Sync_Definition commented specificaly and 170 -- the others are not??? 171 172 procedure Traverse_Generic_Package_Declaration (N : Node_Id); 173 procedure Traverse_Handled_Statement_Sequence 174 (N : Node_Id; 175 D : Dominant_Info := No_Dominant); 176 procedure Traverse_Package_Body (N : Node_Id); 177 procedure Traverse_Package_Declaration 178 (N : Node_Id; 179 D : Dominant_Info := No_Dominant); 180 procedure Traverse_Subprogram_Or_Task_Body 181 (N : Node_Id; 182 D : Dominant_Info := No_Dominant); 183 184 procedure Traverse_Sync_Definition (N : Node_Id); 185 -- Traverse a protected definition or task definition 186 187 procedure Write_SCOs_To_ALI_File is new Put_SCOs; 188 -- Write SCO information to the ALI file using routines in Lib.Util 189 190 ---------- 191 -- dsco -- 192 ---------- 193 194 procedure dsco is 195 begin 196 -- Dump SCO unit table 197 198 Write_Line ("SCO Unit Table"); 199 Write_Line ("--------------"); 200 201 for Index in 1 .. SCO_Unit_Table.Last loop 202 declare 203 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index); 204 205 begin 206 Write_Str (" "); 207 Write_Int (Int (Index)); 208 Write_Str (". Dep_Num = "); 209 Write_Int (Int (UTE.Dep_Num)); 210 Write_Str (" From = "); 211 Write_Int (Int (UTE.From)); 212 Write_Str (" To = "); 213 Write_Int (Int (UTE.To)); 214 215 Write_Str (" File_Name = """); 216 217 if UTE.File_Name /= null then 218 Write_Str (UTE.File_Name.all); 219 end if; 220 221 Write_Char ('"'); 222 Write_Eol; 223 end; 224 end loop; 225 226 -- Dump SCO Unit number table if it contains any entries 227 228 if SCO_Unit_Number_Table.Last >= 1 then 229 Write_Eol; 230 Write_Line ("SCO Unit Number Table"); 231 Write_Line ("---------------------"); 232 233 for Index in 1 .. SCO_Unit_Number_Table.Last loop 234 Write_Str (" "); 235 Write_Int (Int (Index)); 236 Write_Str (". Unit_Number = "); 237 Write_Int (Int (SCO_Unit_Number_Table.Table (Index))); 238 Write_Eol; 239 end loop; 240 end if; 241 242 -- Dump SCO table itself 243 244 Write_Eol; 245 Write_Line ("SCO Table"); 246 Write_Line ("---------"); 247 248 for Index in 1 .. SCO_Table.Last loop 249 declare 250 T : SCO_Table_Entry renames SCO_Table.Table (Index); 251 252 begin 253 Write_Str (" "); 254 Write_Int (Index); 255 Write_Char ('.'); 256 257 if T.C1 /= ' ' then 258 Write_Str (" C1 = '"); 259 Write_Char (T.C1); 260 Write_Char ('''); 261 end if; 262 263 if T.C2 /= ' ' then 264 Write_Str (" C2 = '"); 265 Write_Char (T.C2); 266 Write_Char ('''); 267 end if; 268 269 if T.From /= No_Source_Location then 270 Write_Str (" From = "); 271 Write_Int (Int (T.From.Line)); 272 Write_Char (':'); 273 Write_Int (Int (T.From.Col)); 274 end if; 275 276 if T.To /= No_Source_Location then 277 Write_Str (" To = "); 278 Write_Int (Int (T.To.Line)); 279 Write_Char (':'); 280 Write_Int (Int (T.To.Col)); 281 end if; 282 283 if T.Last then 284 Write_Str (" True"); 285 else 286 Write_Str (" False"); 287 end if; 288 289 Write_Eol; 290 end; 291 end loop; 292 end dsco; 293 294 ----------- 295 -- Equal -- 296 ----------- 297 298 function Equal (F1, F2 : Source_Ptr) return Boolean is 299 begin 300 return F1 = F2; 301 end Equal; 302 303 ------------------ 304 -- Has_Decision -- 305 ------------------ 306 307 function Has_Decision (N : Node_Id) return Boolean is 308 309 function Check_Node (N : Node_Id) return Traverse_Result; 310 311 ---------------- 312 -- Check_Node -- 313 ---------------- 314 315 function Check_Node (N : Node_Id) return Traverse_Result is 316 begin 317 if Is_Logical_Operator (N) then 318 return Abandon; 319 else 320 return OK; 321 end if; 322 end Check_Node; 323 324 function Traverse is new Traverse_Func (Check_Node); 325 326 -- Start of processing for Has_Decision 327 328 begin 329 return Traverse (N) = Abandon; 330 end Has_Decision; 331 332 ---------- 333 -- Hash -- 334 ---------- 335 336 function Hash (F : Source_Ptr) return Header_Num is 337 begin 338 return Header_Num (Nat (F) mod 997); 339 end Hash; 340 341 ---------------- 342 -- Initialize -- 343 ---------------- 344 345 procedure Initialize is 346 begin 347 SCO_Unit_Number_Table.Init; 348 349 -- Set dummy 0'th entry in place for sort 350 351 SCO_Unit_Number_Table.Increment_Last; 352 end Initialize; 353 354 ------------------------- 355 -- Is_Logical_Operator -- 356 ------------------------- 357 358 function Is_Logical_Operator (N : Node_Id) return Boolean is 359 begin 360 return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else); 361 end Is_Logical_Operator; 362 363 ----------------------- 364 -- Process_Decisions -- 365 ----------------------- 366 367 -- Version taking a list 368 369 procedure Process_Decisions 370 (L : List_Id; 371 T : Character; 372 Pragma_Sloc : Source_Ptr) 373 is 374 N : Node_Id; 375 begin 376 if L /= No_List then 377 N := First (L); 378 while Present (N) loop 379 Process_Decisions (N, T, Pragma_Sloc); 380 Next (N); 381 end loop; 382 end if; 383 end Process_Decisions; 384 385 -- Version taking a node 386 387 Current_Pragma_Sloc : Source_Ptr := No_Location; 388 -- While processing a pragma, this is set to the sloc of the N_Pragma node 389 390 procedure Process_Decisions 391 (N : Node_Id; 392 T : Character; 393 Pragma_Sloc : Source_Ptr) 394 is 395 Mark : Nat; 396 -- This is used to mark the location of a decision sequence in the SCO 397 -- table. We use it for backing out a simple decision in an expression 398 -- context that contains only NOT operators. 399 400 X_Not_Decision : Boolean; 401 -- This flag keeps track of whether a decision sequence in the SCO table 402 -- contains only NOT operators, and is for an expression context (T=X). 403 -- The flag will be set False if T is other than X, or if an operator 404 -- other than NOT is in the sequence. 405 406 function Process_Node (N : Node_Id) return Traverse_Result; 407 -- Processes one node in the traversal, looking for logical operators, 408 -- and if one is found, outputs the appropriate table entries. 409 410 procedure Output_Decision_Operand (N : Node_Id); 411 -- The node N is the top level logical operator of a decision, or it is 412 -- one of the operands of a logical operator belonging to a single 413 -- complex decision. This routine outputs the sequence of table entries 414 -- corresponding to the node. Note that we do not process the sub- 415 -- operands to look for further decisions, that processing is done in 416 -- Process_Decision_Operand, because we can't get decisions mixed up in 417 -- the global table. Call has no effect if N is Empty. 418 419 procedure Output_Element (N : Node_Id); 420 -- Node N is an operand of a logical operator that is not itself a 421 -- logical operator, or it is a simple decision. This routine outputs 422 -- the table entry for the element, with C1 set to ' '. Last is set 423 -- False, and an entry is made in the condition hash table. 424 425 procedure Output_Header (T : Character); 426 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ 427 -- PRAGMA, and 'X' for the expression case. 428 429 procedure Process_Decision_Operand (N : Node_Id); 430 -- This is called on node N, the top level node of a decision, or on one 431 -- of its operands or suboperands after generating the full output for 432 -- the complex decision. It process the suboperands of the decision 433 -- looking for nested decisions. 434 435 ----------------------------- 436 -- Output_Decision_Operand -- 437 ----------------------------- 438 439 procedure Output_Decision_Operand (N : Node_Id) is 440 C : Character; 441 L : Node_Id; 442 443 begin 444 if No (N) then 445 return; 446 447 -- Logical operator 448 449 elsif Is_Logical_Operator (N) then 450 if Nkind (N) = N_Op_Not then 451 C := '!'; 452 L := Empty; 453 454 else 455 L := Left_Opnd (N); 456 457 if Nkind_In (N, N_Op_Or, N_Or_Else) then 458 C := '|'; 459 else 460 C := '&'; 461 end if; 462 end if; 463 464 Set_Table_Entry 465 (C1 => C, 466 C2 => ' ', 467 From => Sloc (N), 468 To => No_Location, 469 Last => False); 470 471 Output_Decision_Operand (L); 472 Output_Decision_Operand (Right_Opnd (N)); 473 474 -- Not a logical operator 475 476 else 477 Output_Element (N); 478 end if; 479 end Output_Decision_Operand; 480 481 -------------------- 482 -- Output_Element -- 483 -------------------- 484 485 procedure Output_Element (N : Node_Id) is 486 FSloc : Source_Ptr; 487 LSloc : Source_Ptr; 488 begin 489 Sloc_Range (N, FSloc, LSloc); 490 Set_Table_Entry 491 (C1 => ' ', 492 C2 => 'c', 493 From => FSloc, 494 To => LSloc, 495 Last => False); 496 Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last); 497 end Output_Element; 498 499 ------------------- 500 -- Output_Header -- 501 ------------------- 502 503 procedure Output_Header (T : Character) is 504 Loc : Source_Ptr := No_Location; 505 -- Node whose Sloc is used for the decision 506 507 Nam : Name_Id := No_Name; 508 -- For the case of an aspect, aspect name 509 510 begin 511 case T is 512 when 'I' | 'E' | 'W' | 'a' | 'A' => 513 514 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of 515 -- the parent of the expression. 516 517 Loc := Sloc (Parent (N)); 518 519 if T = 'a' or else T = 'A' then 520 Nam := Chars (Identifier (Parent (N))); 521 end if; 522 523 when 'G' | 'P' => 524 525 -- For entry guard, the token sloc is from the N_Entry_Body. 526 -- For PRAGMA, we must get the location from the pragma node. 527 -- Argument N is the pragma argument, and we have to go up 528 -- two levels (through the pragma argument association) to 529 -- get to the pragma node itself. For the guard on a select 530 -- alternative, we do not have access to the token location for 531 -- the WHEN, so we use the first sloc of the condition itself 532 -- (note: we use First_Sloc, not Sloc, because this is what is 533 -- referenced by dominance markers). 534 535 -- Doesn't this requirement of using First_Sloc need to be 536 -- documented in the spec ??? 537 538 if Nkind_In (Parent (N), N_Accept_Alternative, 539 N_Delay_Alternative, 540 N_Terminate_Alternative) 541 then 542 Loc := First_Sloc (N); 543 else 544 Loc := Sloc (Parent (Parent (N))); 545 end if; 546 547 when 'X' => 548 549 -- For an expression, no Sloc 550 551 null; 552 553 -- No other possibilities 554 555 when others => 556 raise Program_Error; 557 end case; 558 559 Set_Table_Entry 560 (C1 => T, 561 C2 => ' ', 562 From => Loc, 563 To => No_Location, 564 Last => False, 565 Pragma_Sloc => Pragma_Sloc, 566 Pragma_Aspect_Name => Nam); 567 568 -- For an aspect specification, which will be rewritten into a 569 -- pragma, enter a hash table entry now. 570 571 if T = 'a' then 572 Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); 573 end if; 574 end Output_Header; 575 576 ------------------------------ 577 -- Process_Decision_Operand -- 578 ------------------------------ 579 580 procedure Process_Decision_Operand (N : Node_Id) is 581 begin 582 if Is_Logical_Operator (N) then 583 if Nkind (N) /= N_Op_Not then 584 Process_Decision_Operand (Left_Opnd (N)); 585 X_Not_Decision := False; 586 end if; 587 588 Process_Decision_Operand (Right_Opnd (N)); 589 590 else 591 Process_Decisions (N, 'X', Pragma_Sloc); 592 end if; 593 end Process_Decision_Operand; 594 595 ------------------ 596 -- Process_Node -- 597 ------------------ 598 599 function Process_Node (N : Node_Id) return Traverse_Result is 600 begin 601 case Nkind (N) is 602 603 -- Logical operators, output table entries and then process 604 -- operands recursively to deal with nested conditions. 605 606 when N_And_Then | N_Or_Else | N_Op_Not => 607 declare 608 T : Character; 609 610 begin 611 -- If outer level, then type comes from call, otherwise it 612 -- is more deeply nested and counts as X for expression. 613 614 if N = Process_Decisions.N then 615 T := Process_Decisions.T; 616 else 617 T := 'X'; 618 end if; 619 620 -- Output header for sequence 621 622 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; 623 Mark := SCO_Table.Last; 624 Output_Header (T); 625 626 -- Output the decision 627 628 Output_Decision_Operand (N); 629 630 -- If the decision was in an expression context (T = 'X') 631 -- and contained only NOT operators, then we don't output 632 -- it, so delete it. 633 634 if X_Not_Decision then 635 SCO_Table.Set_Last (Mark); 636 637 -- Otherwise, set Last in last table entry to mark end 638 639 else 640 SCO_Table.Table (SCO_Table.Last).Last := True; 641 end if; 642 643 -- Process any embedded decisions 644 645 Process_Decision_Operand (N); 646 return Skip; 647 end; 648 649 -- Case expression 650 651 -- Really hard to believe this is correct given the special 652 -- handling for if expressions below ??? 653 654 when N_Case_Expression => 655 return OK; -- ??? 656 657 -- If expression, processed like an if statement 658 659 when N_If_Expression => 660 declare 661 Cond : constant Node_Id := First (Expressions (N)); 662 Thnx : constant Node_Id := Next (Cond); 663 Elsx : constant Node_Id := Next (Thnx); 664 begin 665 Process_Decisions (Cond, 'I', Pragma_Sloc); 666 Process_Decisions (Thnx, 'X', Pragma_Sloc); 667 Process_Decisions (Elsx, 'X', Pragma_Sloc); 668 return Skip; 669 end; 670 671 -- All other cases, continue scan 672 673 when others => 674 return OK; 675 676 end case; 677 end Process_Node; 678 679 procedure Traverse is new Traverse_Proc (Process_Node); 680 681 -- Start of processing for Process_Decisions 682 683 begin 684 if No (N) then 685 return; 686 end if; 687 688 -- See if we have simple decision at outer level and if so then 689 -- generate the decision entry for this simple decision. A simple 690 -- decision is a boolean expression (which is not a logical operator 691 -- or short circuit form) appearing as the operand of an IF, WHILE, 692 -- EXIT WHEN, or special PRAGMA construct. 693 694 if T /= 'X' and then not Is_Logical_Operator (N) then 695 Output_Header (T); 696 Output_Element (N); 697 698 -- Change Last in last table entry to True to mark end of 699 -- sequence, which is this case is only one element long. 700 701 SCO_Table.Table (SCO_Table.Last).Last := True; 702 end if; 703 704 Traverse (N); 705 end Process_Decisions; 706 707 ----------- 708 -- pscos -- 709 ----------- 710 711 procedure pscos is 712 713 procedure Write_Info_Char (C : Character) renames Write_Char; 714 -- Write one character; 715 716 procedure Write_Info_Initiate (Key : Character) renames Write_Char; 717 -- Start new one and write one character; 718 719 procedure Write_Info_Nat (N : Nat); 720 -- Write value of N 721 722 procedure Write_Info_Terminate renames Write_Eol; 723 -- Terminate current line 724 725 -------------------- 726 -- Write_Info_Nat -- 727 -------------------- 728 729 procedure Write_Info_Nat (N : Nat) is 730 begin 731 Write_Int (N); 732 end Write_Info_Nat; 733 734 procedure Debug_Put_SCOs is new Put_SCOs; 735 736 -- Start of processing for pscos 737 738 begin 739 Debug_Put_SCOs; 740 end pscos; 741 742 --------------------- 743 -- Record_Instance -- 744 --------------------- 745 746 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is 747 Inst_Src : constant Source_File_Index := 748 Get_Source_File_Index (Inst_Sloc); 749 begin 750 SCO_Instance_Table.Append 751 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)), 752 Inst_Loc => To_Source_Location (Inst_Sloc), 753 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src)))); 754 pragma Assert 755 (SCO_Instance_Table.Last = SCO_Instance_Index (Id)); 756 end Record_Instance; 757 758 ---------------- 759 -- SCO_Output -- 760 ---------------- 761 762 procedure SCO_Output is 763 procedure Populate_SCO_Instance_Table is 764 new Sinput.Iterate_On_Instances (Record_Instance); 765 766 SCO_Index : Nat; 767 768 begin 769 if Debug_Flag_Dot_OO then 770 dsco; 771 end if; 772 773 Populate_SCO_Instance_Table; 774 775 -- Sort the unit tables based on dependency numbers 776 777 Unit_Table_Sort : declare 778 779 function Lt (Op1, Op2 : Natural) return Boolean; 780 -- Comparison routine for sort call 781 782 procedure Move (From : Natural; To : Natural); 783 -- Move routine for sort call 784 785 -------- 786 -- Lt -- 787 -------- 788 789 function Lt (Op1, Op2 : Natural) return Boolean is 790 begin 791 return 792 Dependency_Num 793 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1))) 794 < 795 Dependency_Num 796 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2))); 797 end Lt; 798 799 ---------- 800 -- Move -- 801 ---------- 802 803 procedure Move (From : Natural; To : Natural) is 804 begin 805 SCO_Unit_Table.Table (SCO_Unit_Index (To)) := 806 SCO_Unit_Table.Table (SCO_Unit_Index (From)); 807 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) := 808 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From)); 809 end Move; 810 811 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 812 813 -- Start of processing for Unit_Table_Sort 814 815 begin 816 Sorting.Sort (Integer (SCO_Unit_Table.Last)); 817 end Unit_Table_Sort; 818 819 -- Loop through entries in the unit table to set file name and 820 -- dependency number entries. 821 822 for J in 1 .. SCO_Unit_Table.Last loop 823 declare 824 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J); 825 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J); 826 begin 827 Get_Name_String (Reference_Name (Source_Index (U))); 828 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len)); 829 UTE.Dep_Num := Dependency_Num (U); 830 end; 831 end loop; 832 833 -- Stamp out SCO entries for decisions in disabled constructs (pragmas 834 -- or aspects). 835 836 SCO_Index := 1; 837 while SCO_Index <= SCO_Table.Last loop 838 if Is_Decision (SCO_Table.Table (SCO_Index).C1) 839 and then SCO_Pragma_Disabled 840 (SCO_Table.Table (SCO_Index).Pragma_Sloc) 841 then 842 loop 843 SCO_Table.Table (SCO_Index).C1 := ASCII.NUL; 844 exit when SCO_Table.Table (SCO_Index).Last; 845 SCO_Index := SCO_Index + 1; 846 end loop; 847 end if; 848 849 SCO_Index := SCO_Index + 1; 850 end loop; 851 852 -- Now the tables are all setup for output to the ALI file 853 854 Write_SCOs_To_ALI_File; 855 end SCO_Output; 856 857 ------------------------- 858 -- SCO_Pragma_Disabled -- 859 ------------------------- 860 861 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is 862 Index : Nat; 863 864 begin 865 if Loc = No_Location then 866 return False; 867 end if; 868 869 Index := Condition_Pragma_Hash_Table.Get (Loc); 870 871 -- The test here for zero is to deal with possible previous errors, and 872 -- for the case of pragma statement SCOs, for which we always set the 873 -- Pragma_Sloc even if the particular pragma cannot be specifically 874 -- disabled. 875 876 if Index /= 0 then 877 declare 878 T : SCO_Table_Entry renames SCO_Table.Table (Index); 879 begin 880 case T.C1 is 881 when 'S' => 882 -- Pragma statement 883 884 return T.C2 = 'p'; 885 886 when 'A' => 887 -- Aspect decision (enabled) 888 889 return False; 890 891 when 'a' => 892 -- Aspect decision (not enabled) 893 894 return True; 895 896 when ASCII.NUL => 897 -- Nullified disabled SCO 898 899 return True; 900 901 when others => 902 raise Program_Error; 903 end case; 904 end; 905 906 else 907 return False; 908 end if; 909 end SCO_Pragma_Disabled; 910 911 ---------------- 912 -- SCO_Record -- 913 ---------------- 914 915 procedure SCO_Record (U : Unit_Number_Type) is 916 Lu : Node_Id; 917 From : Nat; 918 919 procedure Traverse_Aux_Decls (N : Node_Id); 920 -- Traverse the Aux_Decls_Node of compilation unit N 921 922 ------------------------ 923 -- Traverse_Aux_Decls -- 924 ------------------------ 925 926 procedure Traverse_Aux_Decls (N : Node_Id) is 927 ADN : constant Node_Id := Aux_Decls_Node (N); 928 begin 929 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); 930 Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); 931 932 -- Declarations and Actions do not correspond to source constructs, 933 -- they contain only nodes from expansion, so at this point they 934 -- should still be empty: 935 936 pragma Assert (No (Declarations (ADN))); 937 pragma Assert (No (Actions (ADN))); 938 end Traverse_Aux_Decls; 939 940 -- Start of processing for SCO_Record 941 942 begin 943 -- Ignore call if not generating code and generating SCO's 944 945 if not (Generate_SCO and then Operating_Mode = Generate_Code) then 946 return; 947 end if; 948 949 -- Ignore call if this unit already recorded 950 951 for J in 1 .. SCO_Unit_Number_Table.Last loop 952 if U = SCO_Unit_Number_Table.Table (J) then 953 return; 954 end if; 955 end loop; 956 957 -- Otherwise record starting entry 958 959 From := SCO_Table.Last + 1; 960 961 -- Get Unit (checking case of subunit) 962 963 Lu := Unit (Cunit (U)); 964 965 if Nkind (Lu) = N_Subunit then 966 Lu := Proper_Body (Lu); 967 end if; 968 969 -- Traverse the unit 970 971 Traverse_Aux_Decls (Cunit (U)); 972 973 case Nkind (Lu) is 974 when 975 N_Package_Declaration | 976 N_Package_Body | 977 N_Subprogram_Declaration | 978 N_Subprogram_Body | 979 N_Generic_Package_Declaration | 980 N_Protected_Body | 981 N_Task_Body | 982 N_Generic_Instantiation => 983 984 Traverse_Declarations_Or_Statements (L => No_List, P => Lu); 985 986 when others => 987 988 -- All other cases of compilation units (e.g. renamings), generate 989 -- no SCO information. 990 991 null; 992 end case; 993 994 -- Make entry for new unit in unit tables, we will fill in the file 995 -- name and dependency numbers later. 996 997 SCO_Unit_Table.Append ( 998 (Dep_Num => 0, 999 File_Name => null, 1000 From => From, 1001 To => SCO_Table.Last)); 1002 1003 SCO_Unit_Number_Table.Append (U); 1004 end SCO_Record; 1005 1006 ----------------------- 1007 -- Set_SCO_Condition -- 1008 ----------------------- 1009 1010 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is 1011 Orig : constant Node_Id := Original_Node (Cond); 1012 Index : Nat; 1013 Start : Source_Ptr; 1014 Dummy : Source_Ptr; 1015 1016 Constant_Condition_Code : constant array (Boolean) of Character := 1017 (False => 'f', True => 't'); 1018 begin 1019 Sloc_Range (Orig, Start, Dummy); 1020 Index := Condition_Pragma_Hash_Table.Get (Start); 1021 1022 -- Index can be zero for boolean expressions that do not have SCOs 1023 -- (simple decisions outside of a control flow structure), or in case 1024 -- of a previous error. 1025 1026 if Index = 0 then 1027 return; 1028 1029 else 1030 pragma Assert (SCO_Table.Table (Index).C1 = ' '); 1031 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); 1032 end if; 1033 end Set_SCO_Condition; 1034 1035 ---------------------------- 1036 -- Set_SCO_Pragma_Enabled -- 1037 ---------------------------- 1038 1039 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is 1040 Index : Nat; 1041 1042 begin 1043 -- Nothing to do if not generating SCO, or if we're not processing the 1044 -- original source occurrence of the pragma. 1045 1046 if not (Generate_SCO 1047 and then In_Extended_Main_Source_Unit (Loc) 1048 and then not (In_Instance or In_Inlined_Body)) 1049 then 1050 return; 1051 end if; 1052 1053 -- Note: the reason we use the Sloc value as the key is that in the 1054 -- generic case, the call to this procedure is made on a copy of the 1055 -- original node, so we can't use the Node_Id value. 1056 1057 Index := Condition_Pragma_Hash_Table.Get (Loc); 1058 1059 -- A zero index here indicates that semantic analysis found an 1060 -- activated pragma at Loc which does not have a corresponding pragma 1061 -- or aspect at the syntax level. This may occur in legitimate cases 1062 -- because of expanded code (such are Pre/Post conditions generated for 1063 -- formal parameter validity checks), or as a consequence of a previous 1064 -- error. 1065 1066 if Index = 0 then 1067 return; 1068 1069 else 1070 declare 1071 T : SCO_Table_Entry renames SCO_Table.Table (Index); 1072 1073 begin 1074 -- Note: may be called multiple times for the same sloc, so 1075 -- account for the fact that the entry may already have been 1076 -- marked enabled. 1077 1078 case T.C1 is 1079 -- Aspect (decision SCO) 1080 1081 when 'a' => 1082 T.C1 := 'A'; 1083 1084 when 'A' => 1085 null; 1086 1087 -- Pragma (statement SCO) 1088 1089 when 'S' => 1090 pragma Assert (T.C2 = 'p' or else T.C2 = 'P'); 1091 T.C2 := 'P'; 1092 1093 when others => 1094 raise Program_Error; 1095 end case; 1096 end; 1097 end if; 1098 end Set_SCO_Pragma_Enabled; 1099 1100 --------------------- 1101 -- Set_Table_Entry -- 1102 --------------------- 1103 1104 procedure Set_Table_Entry 1105 (C1 : Character; 1106 C2 : Character; 1107 From : Source_Ptr; 1108 To : Source_Ptr; 1109 Last : Boolean; 1110 Pragma_Sloc : Source_Ptr := No_Location; 1111 Pragma_Aspect_Name : Name_Id := No_Name) 1112 is 1113 begin 1114 SCO_Table.Append 1115 ((C1 => C1, 1116 C2 => C2, 1117 From => To_Source_Location (From), 1118 To => To_Source_Location (To), 1119 Last => Last, 1120 Pragma_Sloc => Pragma_Sloc, 1121 Pragma_Aspect_Name => Pragma_Aspect_Name)); 1122 end Set_Table_Entry; 1123 1124 ------------------------ 1125 -- To_Source_Location -- 1126 ------------------------ 1127 1128 function To_Source_Location (S : Source_Ptr) return Source_Location is 1129 begin 1130 if S = No_Location then 1131 return No_Source_Location; 1132 else 1133 return 1134 (Line => Get_Logical_Line_Number (S), 1135 Col => Get_Column_Number (S)); 1136 end if; 1137 end To_Source_Location; 1138 1139 ----------------------------------------- 1140 -- Traverse_Declarations_Or_Statements -- 1141 ----------------------------------------- 1142 1143 -- Tables used by Traverse_Declarations_Or_Statements for temporarily 1144 -- holding statement and decision entries. These are declared globally 1145 -- since they are shared by recursive calls to this procedure. 1146 1147 type SC_Entry is record 1148 N : Node_Id; 1149 From : Source_Ptr; 1150 To : Source_Ptr; 1151 Typ : Character; 1152 end record; 1153 -- Used to store a single entry in the following table, From:To represents 1154 -- the range of entries in the CS line entry, and typ is the type, with 1155 -- space meaning that no type letter will accompany the entry. 1156 1157 package SC is new Table.Table ( 1158 Table_Component_Type => SC_Entry, 1159 Table_Index_Type => Nat, 1160 Table_Low_Bound => 1, 1161 Table_Initial => 1000, 1162 Table_Increment => 200, 1163 Table_Name => "SCO_SC"); 1164 -- Used to store statement components for a CS entry to be output 1165 -- as a result of the call to this procedure. SC.Last is the last 1166 -- entry stored, so the current statement sequence is represented 1167 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on 1168 -- entry to each recursive call to the routine. 1169 -- 1170 -- Extend_Statement_Sequence adds an entry to this array, and then 1171 -- Set_Statement_Entry clears the entries starting with SC_First, 1172 -- copying these entries to the main SCO output table. The reason that 1173 -- we do the temporary caching of results in this array is that we want 1174 -- the SCO table entries for a given CS line to be contiguous, and the 1175 -- processing may output intermediate entries such as decision entries. 1176 1177 type SD_Entry is record 1178 Nod : Node_Id; 1179 Lst : List_Id; 1180 Typ : Character; 1181 Plo : Source_Ptr; 1182 end record; 1183 -- Used to store a single entry in the following table. Nod is the node to 1184 -- be searched for decisions for the case of Process_Decisions_Defer with a 1185 -- node argument (with Lst set to No_List. Lst is the list to be searched 1186 -- for decisions for the case of Process_Decisions_Defer with a List 1187 -- argument (in which case Nod is set to Empty). Plo is the sloc of the 1188 -- enclosing pragma, if any. 1189 1190 package SD is new Table.Table ( 1191 Table_Component_Type => SD_Entry, 1192 Table_Index_Type => Nat, 1193 Table_Low_Bound => 1, 1194 Table_Initial => 1000, 1195 Table_Increment => 200, 1196 Table_Name => "SCO_SD"); 1197 -- Used to store possible decision information. Instead of calling the 1198 -- Process_Decisions procedures directly, we call Process_Decisions_Defer, 1199 -- which simply stores the arguments in this table. Then when we clear 1200 -- out a statement sequence using Set_Statement_Entry, after generating 1201 -- the CS lines for the statements, the entries in this table result in 1202 -- calls to Process_Decision. The reason for doing things this way is to 1203 -- ensure that decisions are output after the CS line for the statements 1204 -- in which the decisions occur. 1205 1206 procedure Traverse_Declarations_Or_Statements 1207 (L : List_Id; 1208 D : Dominant_Info := No_Dominant; 1209 P : Node_Id := Empty) 1210 is 1211 Discard_Dom : Dominant_Info; 1212 pragma Warnings (Off, Discard_Dom); 1213 begin 1214 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P); 1215 end Traverse_Declarations_Or_Statements; 1216 1217 function Traverse_Declarations_Or_Statements 1218 (L : List_Id; 1219 D : Dominant_Info := No_Dominant; 1220 P : Node_Id := Empty) return Dominant_Info 1221 is 1222 Current_Dominant : Dominant_Info := D; 1223 -- Dominance information for the current basic block 1224 1225 Current_Test : Node_Id; 1226 -- Conditional node (N_If_Statement or N_Elsiif being processed 1227 1228 N : Node_Id; 1229 1230 SC_First : constant Nat := SC.Last + 1; 1231 SD_First : constant Nat := SD.Last + 1; 1232 -- Record first entries used in SC/SD at this recursive level 1233 1234 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); 1235 -- Extend the current statement sequence to encompass the node N. Typ 1236 -- is the letter that identifies the type of statement/declaration that 1237 -- is being added to the sequence. 1238 1239 procedure Set_Statement_Entry; 1240 -- Output CS entries for all statements saved in table SC, and end the 1241 -- current CS sequence. Then output entries for all decisions nested in 1242 -- these statements, which have been deferred so far. 1243 1244 procedure Process_Decisions_Defer (N : Node_Id; T : Character); 1245 pragma Inline (Process_Decisions_Defer); 1246 -- This routine is logically the same as Process_Decisions, except that 1247 -- the arguments are saved in the SD table for later processing when 1248 -- Set_Statement_Entry is called, which goes through the saved entries 1249 -- making the corresponding calls to Process_Decision. 1250 1251 procedure Process_Decisions_Defer (L : List_Id; T : Character); 1252 pragma Inline (Process_Decisions_Defer); 1253 -- Same case for list arguments, deferred call to Process_Decisions 1254 1255 procedure Traverse_One (N : Node_Id); 1256 -- Traverse one declaration or statement 1257 1258 procedure Traverse_Aspects (N : Node_Id); 1259 -- Helper for Traverse_One: traverse N's aspect specifications 1260 1261 ------------------------- 1262 -- Set_Statement_Entry -- 1263 ------------------------- 1264 1265 procedure Set_Statement_Entry is 1266 SC_Last : constant Int := SC.Last; 1267 SD_Last : constant Int := SD.Last; 1268 1269 begin 1270 -- Output statement entries from saved entries in SC table 1271 1272 for J in SC_First .. SC_Last loop 1273 if J = SC_First then 1274 1275 if Current_Dominant /= No_Dominant then 1276 declare 1277 From, To : Source_Ptr; 1278 begin 1279 Sloc_Range (Current_Dominant.N, From, To); 1280 if Current_Dominant.K /= 'E' then 1281 To := No_Location; 1282 end if; 1283 Set_Table_Entry 1284 (C1 => '>', 1285 C2 => Current_Dominant.K, 1286 From => From, 1287 To => To, 1288 Last => False, 1289 Pragma_Sloc => No_Location, 1290 Pragma_Aspect_Name => No_Name); 1291 end; 1292 end if; 1293 end if; 1294 1295 declare 1296 SCE : SC_Entry renames SC.Table (J); 1297 Pragma_Sloc : Source_Ptr := No_Location; 1298 Pragma_Aspect_Name : Name_Id := No_Name; 1299 begin 1300 -- For the case of a statement SCO for a pragma controlled by 1301 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and 1302 -- those of any nested decision) is emitted only if the pragma 1303 -- is enabled. 1304 1305 if SCE.Typ = 'p' then 1306 Pragma_Sloc := SCE.From; 1307 Condition_Pragma_Hash_Table.Set 1308 (Pragma_Sloc, SCO_Table.Last + 1); 1309 Pragma_Aspect_Name := Pragma_Name (SCE.N); 1310 pragma Assert (Pragma_Aspect_Name /= No_Name); 1311 1312 elsif SCE.Typ = 'P' then 1313 Pragma_Aspect_Name := Pragma_Name (SCE.N); 1314 pragma Assert (Pragma_Aspect_Name /= No_Name); 1315 end if; 1316 1317 Set_Table_Entry 1318 (C1 => 'S', 1319 C2 => SCE.Typ, 1320 From => SCE.From, 1321 To => SCE.To, 1322 Last => (J = SC_Last), 1323 Pragma_Sloc => Pragma_Sloc, 1324 Pragma_Aspect_Name => Pragma_Aspect_Name); 1325 end; 1326 end loop; 1327 1328 -- Last statement of basic block, if present, becomes new current 1329 -- dominant. 1330 1331 if SC_Last >= SC_First then 1332 Current_Dominant := ('S', SC.Table (SC_Last).N); 1333 end if; 1334 1335 -- Clear out used section of SC table 1336 1337 SC.Set_Last (SC_First - 1); 1338 1339 -- Output any embedded decisions 1340 1341 for J in SD_First .. SD_Last loop 1342 declare 1343 SDE : SD_Entry renames SD.Table (J); 1344 begin 1345 if Present (SDE.Nod) then 1346 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); 1347 else 1348 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); 1349 end if; 1350 end; 1351 end loop; 1352 1353 -- Clear out used section of SD table 1354 1355 SD.Set_Last (SD_First - 1); 1356 end Set_Statement_Entry; 1357 1358 ------------------------------- 1359 -- Extend_Statement_Sequence -- 1360 ------------------------------- 1361 1362 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is 1363 F : Source_Ptr; 1364 T : Source_Ptr; 1365 Dummy : Source_Ptr; 1366 To_Node : Node_Id := Empty; 1367 1368 begin 1369 Sloc_Range (N, F, T); 1370 1371 case Nkind (N) is 1372 when N_Accept_Statement => 1373 if Present (Parameter_Specifications (N)) then 1374 To_Node := Last (Parameter_Specifications (N)); 1375 elsif Present (Entry_Index (N)) then 1376 To_Node := Entry_Index (N); 1377 end if; 1378 1379 when N_Case_Statement => 1380 To_Node := Expression (N); 1381 1382 when N_If_Statement | N_Elsif_Part => 1383 To_Node := Condition (N); 1384 1385 when N_Extended_Return_Statement => 1386 To_Node := Last (Return_Object_Declarations (N)); 1387 1388 when N_Loop_Statement => 1389 To_Node := Iteration_Scheme (N); 1390 1391 when N_Selective_Accept | 1392 N_Timed_Entry_Call | 1393 N_Conditional_Entry_Call | 1394 N_Asynchronous_Select | 1395 N_Single_Protected_Declaration | 1396 N_Single_Task_Declaration => 1397 T := F; 1398 1399 when N_Protected_Type_Declaration | N_Task_Type_Declaration => 1400 if Has_Aspects (N) then 1401 To_Node := Last (Aspect_Specifications (N)); 1402 1403 elsif Present (Discriminant_Specifications (N)) then 1404 To_Node := Last (Discriminant_Specifications (N)); 1405 1406 else 1407 To_Node := Defining_Identifier (N); 1408 end if; 1409 1410 when others => 1411 null; 1412 1413 end case; 1414 1415 if Present (To_Node) then 1416 Sloc_Range (To_Node, Dummy, T); 1417 end if; 1418 1419 SC.Append ((N, F, T, Typ)); 1420 end Extend_Statement_Sequence; 1421 1422 ----------------------------- 1423 -- Process_Decisions_Defer -- 1424 ----------------------------- 1425 1426 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is 1427 begin 1428 SD.Append ((N, No_List, T, Current_Pragma_Sloc)); 1429 end Process_Decisions_Defer; 1430 1431 procedure Process_Decisions_Defer (L : List_Id; T : Character) is 1432 begin 1433 SD.Append ((Empty, L, T, Current_Pragma_Sloc)); 1434 end Process_Decisions_Defer; 1435 1436 ---------------------- 1437 -- Traverse_Aspects -- 1438 ---------------------- 1439 1440 procedure Traverse_Aspects (N : Node_Id) is 1441 AN : Node_Id; 1442 AE : Node_Id; 1443 C1 : Character; 1444 1445 begin 1446 AN := First (Aspect_Specifications (N)); 1447 while Present (AN) loop 1448 AE := Expression (AN); 1449 1450 -- SCOs are generated before semantic analysis/expansion: 1451 -- PPCs are not split yet. 1452 1453 pragma Assert (not Split_PPC (AN)); 1454 1455 C1 := ASCII.NUL; 1456 1457 case Get_Aspect_Id (AN) is 1458 1459 -- Aspects rewritten into pragmas controlled by a Check_Policy: 1460 -- Current_Pragma_Sloc must be set to the sloc of the aspect 1461 -- specification. The corresponding pragma will have the same 1462 -- sloc. 1463 1464 when Aspect_Pre | 1465 Aspect_Precondition | 1466 Aspect_Post | 1467 Aspect_Postcondition | 1468 Aspect_Invariant => 1469 1470 C1 := 'a'; 1471 1472 -- Aspects whose checks are generated in client units, 1473 -- regardless of whether or not the check is activated in the 1474 -- unit which contains the declaration: create decision as 1475 -- unconditionally enabled aspect (but still make a pragma 1476 -- entry since Set_SCO_Pragma_Enabled will be called when 1477 -- analyzing actual checks, possibly in other units). 1478 1479 -- Pre/post can have checks in client units too because of 1480 -- inheritance, so should they be moved here??? 1481 1482 when Aspect_Predicate | 1483 Aspect_Static_Predicate | 1484 Aspect_Dynamic_Predicate | 1485 Aspect_Type_Invariant => 1486 1487 C1 := 'A'; 1488 1489 -- Other aspects: just process any decision nested in the 1490 -- aspect expression. 1491 1492 when others => 1493 1494 if Has_Decision (AE) then 1495 C1 := 'X'; 1496 end if; 1497 1498 end case; 1499 1500 if C1 /= ASCII.NUL then 1501 pragma Assert (Current_Pragma_Sloc = No_Location); 1502 1503 if C1 = 'a' or else C1 = 'A' then 1504 Current_Pragma_Sloc := Sloc (AN); 1505 end if; 1506 1507 Process_Decisions_Defer (AE, C1); 1508 1509 Current_Pragma_Sloc := No_Location; 1510 end if; 1511 1512 Next (AN); 1513 end loop; 1514 end Traverse_Aspects; 1515 1516 ------------------ 1517 -- Traverse_One -- 1518 ------------------ 1519 1520 procedure Traverse_One (N : Node_Id) is 1521 begin 1522 -- Initialize or extend current statement sequence. Note that for 1523 -- special cases such as IF and Case statements we will modify 1524 -- the range to exclude internal statements that should not be 1525 -- counted as part of the current statement sequence. 1526 1527 case Nkind (N) is 1528 1529 -- Package declaration 1530 1531 when N_Package_Declaration => 1532 Set_Statement_Entry; 1533 Traverse_Package_Declaration (N, Current_Dominant); 1534 1535 -- Generic package declaration 1536 1537 when N_Generic_Package_Declaration => 1538 Set_Statement_Entry; 1539 Traverse_Generic_Package_Declaration (N); 1540 1541 -- Package body 1542 1543 when N_Package_Body => 1544 Set_Statement_Entry; 1545 Traverse_Package_Body (N); 1546 1547 -- Subprogram declaration or subprogram body stub 1548 1549 when N_Subprogram_Declaration | N_Subprogram_Body_Stub => 1550 Process_Decisions_Defer 1551 (Parameter_Specifications (Specification (N)), 'X'); 1552 1553 -- Entry declaration 1554 1555 when N_Entry_Declaration => 1556 Process_Decisions_Defer (Parameter_Specifications (N), 'X'); 1557 1558 -- Generic subprogram declaration 1559 1560 when N_Generic_Subprogram_Declaration => 1561 Process_Decisions_Defer 1562 (Generic_Formal_Declarations (N), 'X'); 1563 Process_Decisions_Defer 1564 (Parameter_Specifications (Specification (N)), 'X'); 1565 1566 -- Task or subprogram body 1567 1568 when N_Task_Body | N_Subprogram_Body => 1569 Set_Statement_Entry; 1570 Traverse_Subprogram_Or_Task_Body (N); 1571 1572 -- Entry body 1573 1574 when N_Entry_Body => 1575 declare 1576 Cond : constant Node_Id := 1577 Condition (Entry_Body_Formal_Part (N)); 1578 1579 Inner_Dominant : Dominant_Info := No_Dominant; 1580 1581 begin 1582 Set_Statement_Entry; 1583 1584 if Present (Cond) then 1585 Process_Decisions_Defer (Cond, 'G'); 1586 1587 -- For an entry body with a barrier, the entry body 1588 -- is dominanted by a True evaluation of the barrier. 1589 1590 Inner_Dominant := ('T', N); 1591 end if; 1592 1593 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); 1594 end; 1595 1596 -- Protected body 1597 1598 when N_Protected_Body => 1599 Set_Statement_Entry; 1600 Traverse_Declarations_Or_Statements (Declarations (N)); 1601 1602 -- Exit statement, which is an exit statement in the SCO sense, 1603 -- so it is included in the current statement sequence, but 1604 -- then it terminates this sequence. We also have to process 1605 -- any decisions in the exit statement expression. 1606 1607 when N_Exit_Statement => 1608 Extend_Statement_Sequence (N, 'E'); 1609 Process_Decisions_Defer (Condition (N), 'E'); 1610 Set_Statement_Entry; 1611 1612 -- If condition is present, then following statement is 1613 -- only executed if the condition evaluates to False. 1614 1615 if Present (Condition (N)) then 1616 Current_Dominant := ('F', N); 1617 else 1618 Current_Dominant := No_Dominant; 1619 end if; 1620 1621 -- Label, which breaks the current statement sequence, but the 1622 -- label itself is not included in the next statement sequence, 1623 -- since it generates no code. 1624 1625 when N_Label => 1626 Set_Statement_Entry; 1627 Current_Dominant := No_Dominant; 1628 1629 -- Block statement, which breaks the current statement sequence 1630 1631 when N_Block_Statement => 1632 Set_Statement_Entry; 1633 1634 -- The first statement in the handled sequence of statements 1635 -- is dominated by the elaboration of the last declaration. 1636 1637 Current_Dominant := Traverse_Declarations_Or_Statements 1638 (L => Declarations (N), 1639 D => Current_Dominant); 1640 1641 Traverse_Handled_Statement_Sequence 1642 (N => Handled_Statement_Sequence (N), 1643 D => Current_Dominant); 1644 1645 -- If statement, which breaks the current statement sequence, 1646 -- but we include the condition in the current sequence. 1647 1648 when N_If_Statement => 1649 Current_Test := N; 1650 Extend_Statement_Sequence (N, 'I'); 1651 Process_Decisions_Defer (Condition (N), 'I'); 1652 Set_Statement_Entry; 1653 1654 -- Now we traverse the statements in the THEN part 1655 1656 Traverse_Declarations_Or_Statements 1657 (L => Then_Statements (N), 1658 D => ('T', N)); 1659 1660 -- Loop through ELSIF parts if present 1661 1662 if Present (Elsif_Parts (N)) then 1663 declare 1664 Saved_Dominant : constant Dominant_Info := 1665 Current_Dominant; 1666 1667 Elif : Node_Id := First (Elsif_Parts (N)); 1668 1669 begin 1670 while Present (Elif) loop 1671 1672 -- An Elsif is executed only if the previous test 1673 -- got a FALSE outcome. 1674 1675 Current_Dominant := ('F', Current_Test); 1676 1677 -- Now update current test information 1678 1679 Current_Test := Elif; 1680 1681 -- We generate a statement sequence for the 1682 -- construct "ELSIF condition", so that we have 1683 -- a statement for the resulting decisions. 1684 1685 Extend_Statement_Sequence (Elif, 'I'); 1686 Process_Decisions_Defer (Condition (Elif), 'I'); 1687 Set_Statement_Entry; 1688 1689 -- An ELSIF part is never guaranteed to have 1690 -- been executed, following statements are only 1691 -- dominated by the initial IF statement. 1692 1693 Current_Dominant := Saved_Dominant; 1694 1695 -- Traverse the statements in the ELSIF 1696 1697 Traverse_Declarations_Or_Statements 1698 (L => Then_Statements (Elif), 1699 D => ('T', Elif)); 1700 Next (Elif); 1701 end loop; 1702 end; 1703 end if; 1704 1705 -- Finally traverse the ELSE statements if present 1706 1707 Traverse_Declarations_Or_Statements 1708 (L => Else_Statements (N), 1709 D => ('F', Current_Test)); 1710 1711 -- CASE statement, which breaks the current statement sequence, 1712 -- but we include the expression in the current sequence. 1713 1714 when N_Case_Statement => 1715 Extend_Statement_Sequence (N, 'C'); 1716 Process_Decisions_Defer (Expression (N), 'X'); 1717 Set_Statement_Entry; 1718 1719 -- Process case branches, all of which are dominated by the 1720 -- CASE statement. 1721 1722 declare 1723 Alt : Node_Id; 1724 begin 1725 Alt := First (Alternatives (N)); 1726 while Present (Alt) loop 1727 Traverse_Declarations_Or_Statements 1728 (L => Statements (Alt), 1729 D => Current_Dominant); 1730 Next (Alt); 1731 end loop; 1732 end; 1733 1734 -- ACCEPT statement 1735 1736 when N_Accept_Statement => 1737 Extend_Statement_Sequence (N, 'A'); 1738 Set_Statement_Entry; 1739 1740 -- Process sequence of statements, dominant is the ACCEPT 1741 -- statement. 1742 1743 Traverse_Handled_Statement_Sequence 1744 (N => Handled_Statement_Sequence (N), 1745 D => Current_Dominant); 1746 1747 -- SELECT 1748 1749 when N_Selective_Accept => 1750 Extend_Statement_Sequence (N, 'S'); 1751 Set_Statement_Entry; 1752 1753 -- Process alternatives 1754 1755 declare 1756 Alt : Node_Id; 1757 Guard : Node_Id; 1758 S_Dom : Dominant_Info; 1759 1760 begin 1761 Alt := First (Select_Alternatives (N)); 1762 while Present (Alt) loop 1763 S_Dom := Current_Dominant; 1764 Guard := Condition (Alt); 1765 1766 if Present (Guard) then 1767 Process_Decisions 1768 (Guard, 1769 'G', 1770 Pragma_Sloc => No_Location); 1771 Current_Dominant := ('T', Guard); 1772 end if; 1773 1774 Traverse_One (Alt); 1775 1776 Current_Dominant := S_Dom; 1777 Next (Alt); 1778 end loop; 1779 end; 1780 1781 Traverse_Declarations_Or_Statements 1782 (L => Else_Statements (N), 1783 D => Current_Dominant); 1784 1785 when N_Timed_Entry_Call | N_Conditional_Entry_Call => 1786 Extend_Statement_Sequence (N, 'S'); 1787 Set_Statement_Entry; 1788 1789 -- Process alternatives 1790 1791 Traverse_One (Entry_Call_Alternative (N)); 1792 1793 if Nkind (N) = N_Timed_Entry_Call then 1794 Traverse_One (Delay_Alternative (N)); 1795 else 1796 Traverse_Declarations_Or_Statements 1797 (L => Else_Statements (N), 1798 D => Current_Dominant); 1799 end if; 1800 1801 when N_Asynchronous_Select => 1802 Extend_Statement_Sequence (N, 'S'); 1803 Set_Statement_Entry; 1804 1805 Traverse_One (Triggering_Alternative (N)); 1806 Traverse_Declarations_Or_Statements 1807 (L => Statements (Abortable_Part (N)), 1808 D => Current_Dominant); 1809 1810 when N_Accept_Alternative => 1811 Traverse_Declarations_Or_Statements 1812 (L => Statements (N), 1813 D => Current_Dominant, 1814 P => Accept_Statement (N)); 1815 1816 when N_Entry_Call_Alternative => 1817 Traverse_Declarations_Or_Statements 1818 (L => Statements (N), 1819 D => Current_Dominant, 1820 P => Entry_Call_Statement (N)); 1821 1822 when N_Delay_Alternative => 1823 Traverse_Declarations_Or_Statements 1824 (L => Statements (N), 1825 D => Current_Dominant, 1826 P => Delay_Statement (N)); 1827 1828 when N_Triggering_Alternative => 1829 Traverse_Declarations_Or_Statements 1830 (L => Statements (N), 1831 D => Current_Dominant, 1832 P => Triggering_Statement (N)); 1833 1834 when N_Terminate_Alternative => 1835 1836 -- It is dubious to emit a statement SCO for a TERMINATE 1837 -- alternative, since no code is actually executed if the 1838 -- alternative is selected -- the tasking runtime call just 1839 -- never returns??? 1840 1841 Extend_Statement_Sequence (N, ' '); 1842 Set_Statement_Entry; 1843 1844 -- Unconditional exit points, which are included in the current 1845 -- statement sequence, but then terminate it 1846 1847 when N_Requeue_Statement | 1848 N_Goto_Statement | 1849 N_Raise_Statement => 1850 Extend_Statement_Sequence (N, ' '); 1851 Set_Statement_Entry; 1852 Current_Dominant := No_Dominant; 1853 1854 -- Simple return statement. which is an exit point, but we 1855 -- have to process the return expression for decisions. 1856 1857 when N_Simple_Return_Statement => 1858 Extend_Statement_Sequence (N, ' '); 1859 Process_Decisions_Defer (Expression (N), 'X'); 1860 Set_Statement_Entry; 1861 Current_Dominant := No_Dominant; 1862 1863 -- Extended return statement 1864 1865 when N_Extended_Return_Statement => 1866 Extend_Statement_Sequence (N, 'R'); 1867 Process_Decisions_Defer 1868 (Return_Object_Declarations (N), 'X'); 1869 Set_Statement_Entry; 1870 1871 Traverse_Handled_Statement_Sequence 1872 (N => Handled_Statement_Sequence (N), 1873 D => Current_Dominant); 1874 1875 Current_Dominant := No_Dominant; 1876 1877 -- Loop ends the current statement sequence, but we include 1878 -- the iteration scheme if present in the current sequence. 1879 -- But the body of the loop starts a new sequence, since it 1880 -- may not be executed as part of the current sequence. 1881 1882 when N_Loop_Statement => 1883 declare 1884 ISC : constant Node_Id := Iteration_Scheme (N); 1885 Inner_Dominant : Dominant_Info := No_Dominant; 1886 1887 begin 1888 if Present (ISC) then 1889 1890 -- If iteration scheme present, extend the current 1891 -- statement sequence to include the iteration scheme 1892 -- and process any decisions it contains. 1893 1894 -- While loop 1895 1896 if Present (Condition (ISC)) then 1897 Extend_Statement_Sequence (N, 'W'); 1898 Process_Decisions_Defer (Condition (ISC), 'W'); 1899 1900 -- Set more specific dominant for inner statements 1901 -- (the control sloc for the decision is that of 1902 -- the WHILE token). 1903 1904 Inner_Dominant := ('T', ISC); 1905 1906 -- For loop 1907 1908 else 1909 Extend_Statement_Sequence (N, 'F'); 1910 Process_Decisions_Defer 1911 (Loop_Parameter_Specification (ISC), 'X'); 1912 end if; 1913 end if; 1914 1915 Set_Statement_Entry; 1916 1917 if Inner_Dominant = No_Dominant then 1918 Inner_Dominant := Current_Dominant; 1919 end if; 1920 1921 Traverse_Declarations_Or_Statements 1922 (L => Statements (N), 1923 D => Inner_Dominant); 1924 end; 1925 1926 -- Pragma 1927 1928 when N_Pragma => 1929 1930 -- Record sloc of pragma (pragmas don't nest) 1931 1932 pragma Assert (Current_Pragma_Sloc = No_Location); 1933 Current_Pragma_Sloc := Sloc (N); 1934 1935 -- Processing depends on the kind of pragma 1936 1937 declare 1938 Nam : constant Name_Id := Pragma_Name (N); 1939 Arg : Node_Id := 1940 First (Pragma_Argument_Associations (N)); 1941 Typ : Character; 1942 1943 begin 1944 case Nam is 1945 when Name_Assert | 1946 Name_Assert_And_Cut | 1947 Name_Assume | 1948 Name_Check | 1949 Name_Loop_Invariant | 1950 Name_Precondition | 1951 Name_Postcondition => 1952 1953 -- For Assert/Check/Precondition/Postcondition, we 1954 -- must generate a P entry for the decision. Note 1955 -- that this is done unconditionally at this stage. 1956 -- Output for disabled pragmas is suppressed later 1957 -- on when we output the decision line in Put_SCOs, 1958 -- depending on setting by Set_SCO_Pragma_Enabled. 1959 1960 if Nam = Name_Check then 1961 Next (Arg); 1962 end if; 1963 1964 Process_Decisions_Defer (Expression (Arg), 'P'); 1965 Typ := 'p'; 1966 1967 -- Pre/postconditions can be inherited so SCO should 1968 -- never be deactivated??? 1969 1970 when Name_Debug => 1971 if Present (Arg) and then Present (Next (Arg)) then 1972 1973 -- Case of a dyadic pragma Debug: first argument 1974 -- is a P decision, any nested decision in the 1975 -- second argument is an X decision. 1976 1977 Process_Decisions_Defer (Expression (Arg), 'P'); 1978 Next (Arg); 1979 end if; 1980 1981 Process_Decisions_Defer (Expression (Arg), 'X'); 1982 Typ := 'p'; 1983 1984 -- For all other pragmas, we generate decision entries 1985 -- for any embedded expressions, and the pragma is 1986 -- never disabled. 1987 1988 -- Should generate P decisions (not X) for assertion 1989 -- related pragmas: [Type_]Invariant, 1990 -- [{Static,Dynamic}_]Predicate??? 1991 1992 when others => 1993 Process_Decisions_Defer (N, 'X'); 1994 Typ := 'P'; 1995 end case; 1996 1997 -- Add statement SCO 1998 1999 Extend_Statement_Sequence (N, Typ); 2000 2001 Current_Pragma_Sloc := No_Location; 2002 end; 2003 2004 -- Object declaration. Ignored if Prev_Ids is set, since the 2005 -- parser generates multiple instances of the whole declaration 2006 -- if there is more than one identifier declared, and we only 2007 -- want one entry in the SCOs, so we take the first, for which 2008 -- Prev_Ids is False. 2009 2010 when N_Object_Declaration | N_Number_Declaration => 2011 if not Prev_Ids (N) then 2012 Extend_Statement_Sequence (N, 'o'); 2013 2014 if Has_Decision (N) then 2015 Process_Decisions_Defer (N, 'X'); 2016 end if; 2017 end if; 2018 2019 -- All other cases, which extend the current statement sequence 2020 -- but do not terminate it, even if they have nested decisions. 2021 2022 when N_Protected_Type_Declaration | N_Task_Type_Declaration => 2023 Extend_Statement_Sequence (N, 't'); 2024 Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); 2025 Set_Statement_Entry; 2026 2027 Traverse_Sync_Definition (N); 2028 2029 when N_Single_Protected_Declaration | N_Single_Task_Declaration => 2030 Extend_Statement_Sequence (N, 'o'); 2031 Set_Statement_Entry; 2032 2033 Traverse_Sync_Definition (N); 2034 2035 when others => 2036 2037 -- Determine required type character code, or ASCII.NUL if 2038 -- no SCO should be generated for this node. 2039 2040 declare 2041 NK : constant Node_Kind := Nkind (N); 2042 Typ : Character; 2043 2044 begin 2045 case NK is 2046 when N_Full_Type_Declaration | 2047 N_Incomplete_Type_Declaration | 2048 N_Private_Type_Declaration | 2049 N_Private_Extension_Declaration => 2050 Typ := 't'; 2051 2052 when N_Subtype_Declaration => 2053 Typ := 's'; 2054 2055 when N_Renaming_Declaration => 2056 Typ := 'r'; 2057 2058 when N_Generic_Instantiation => 2059 Typ := 'i'; 2060 2061 when N_Representation_Clause | 2062 N_Use_Package_Clause | 2063 N_Use_Type_Clause | 2064 N_Package_Body_Stub | 2065 N_Task_Body_Stub | 2066 N_Protected_Body_Stub => 2067 Typ := ASCII.NUL; 2068 2069 when N_Procedure_Call_Statement => 2070 Typ := ' '; 2071 2072 when others => 2073 if NK in N_Statement_Other_Than_Procedure_Call then 2074 Typ := ' '; 2075 else 2076 Typ := 'd'; 2077 end if; 2078 end case; 2079 2080 if Typ /= ASCII.NUL then 2081 Extend_Statement_Sequence (N, Typ); 2082 end if; 2083 end; 2084 2085 -- Process any embedded decisions 2086 2087 if Has_Decision (N) then 2088 Process_Decisions_Defer (N, 'X'); 2089 end if; 2090 end case; 2091 2092 -- Process aspects if present 2093 2094 Traverse_Aspects (N); 2095 end Traverse_One; 2096 2097 -- Start of processing for Traverse_Declarations_Or_Statements 2098 2099 begin 2100 -- Process single prefixed node 2101 2102 if Present (P) then 2103 Traverse_One (P); 2104 end if; 2105 2106 -- Loop through statements or declarations 2107 2108 if Is_Non_Empty_List (L) then 2109 N := First (L); 2110 while Present (N) loop 2111 2112 -- Note: For separate bodies, we see the tree after Par.Labl has 2113 -- introduced implicit labels, so we need to ignore those nodes. 2114 2115 if Nkind (N) /= N_Implicit_Label_Declaration then 2116 Traverse_One (N); 2117 end if; 2118 2119 Next (N); 2120 end loop; 2121 2122 end if; 2123 2124 -- End sequence of statements and flush deferred decisions 2125 2126 if Present (P) or else Is_Non_Empty_List (L) then 2127 Set_Statement_Entry; 2128 end if; 2129 2130 return Current_Dominant; 2131 end Traverse_Declarations_Or_Statements; 2132 2133 ------------------------------------------ 2134 -- Traverse_Generic_Package_Declaration -- 2135 ------------------------------------------ 2136 2137 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is 2138 begin 2139 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); 2140 Traverse_Package_Declaration (N); 2141 end Traverse_Generic_Package_Declaration; 2142 2143 ----------------------------------------- 2144 -- Traverse_Handled_Statement_Sequence -- 2145 ----------------------------------------- 2146 2147 procedure Traverse_Handled_Statement_Sequence 2148 (N : Node_Id; 2149 D : Dominant_Info := No_Dominant) 2150 is 2151 Handler : Node_Id; 2152 2153 begin 2154 -- For package bodies without a statement part, the parser adds an empty 2155 -- one, to normalize the representation. The null statement therein, 2156 -- which does not come from source, does not get a SCO. 2157 2158 if Present (N) and then Comes_From_Source (N) then 2159 Traverse_Declarations_Or_Statements (Statements (N), D); 2160 2161 if Present (Exception_Handlers (N)) then 2162 Handler := First (Exception_Handlers (N)); 2163 while Present (Handler) loop 2164 Traverse_Declarations_Or_Statements 2165 (L => Statements (Handler), 2166 D => ('E', Handler)); 2167 Next (Handler); 2168 end loop; 2169 end if; 2170 end if; 2171 end Traverse_Handled_Statement_Sequence; 2172 2173 --------------------------- 2174 -- Traverse_Package_Body -- 2175 --------------------------- 2176 2177 procedure Traverse_Package_Body (N : Node_Id) is 2178 Dom : Dominant_Info; 2179 begin 2180 -- The first statement in the handled sequence of statements is 2181 -- dominated by the elaboration of the last declaration. 2182 2183 Dom := Traverse_Declarations_Or_Statements (Declarations (N)); 2184 2185 Traverse_Handled_Statement_Sequence 2186 (Handled_Statement_Sequence (N), Dom); 2187 end Traverse_Package_Body; 2188 2189 ---------------------------------- 2190 -- Traverse_Package_Declaration -- 2191 ---------------------------------- 2192 2193 procedure Traverse_Package_Declaration 2194 (N : Node_Id; 2195 D : Dominant_Info := No_Dominant) 2196 is 2197 Spec : constant Node_Id := Specification (N); 2198 Dom : Dominant_Info; 2199 2200 begin 2201 Dom := 2202 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D); 2203 2204 -- First private declaration is dominated by last visible declaration 2205 2206 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); 2207 end Traverse_Package_Declaration; 2208 2209 ------------------------------ 2210 -- Traverse_Sync_Definition -- 2211 ------------------------------ 2212 2213 procedure Traverse_Sync_Definition (N : Node_Id) is 2214 Dom_Info : Dominant_Info := ('S', N); 2215 -- The first declaration is dominated by the protected or task [type] 2216 -- declaration. 2217 2218 Sync_Def : Node_Id; 2219 -- N's protected or task definition 2220 2221 Vis_Decl : List_Id; 2222 -- Sync_Def's Visible_Declarations 2223 2224 begin 2225 case Nkind (N) is 2226 when N_Single_Protected_Declaration | N_Protected_Type_Declaration => 2227 Sync_Def := Protected_Definition (N); 2228 2229 when N_Single_Task_Declaration | N_Task_Type_Declaration => 2230 Sync_Def := Task_Definition (N); 2231 2232 when others => 2233 raise Program_Error; 2234 end case; 2235 2236 Vis_Decl := Visible_Declarations (Sync_Def); 2237 2238 Dom_Info := Traverse_Declarations_Or_Statements 2239 (L => Vis_Decl, 2240 D => Dom_Info); 2241 2242 -- If visible declarations are present, the first private declaration 2243 -- is dominated by the last visible declaration. 2244 2245 Traverse_Declarations_Or_Statements 2246 (L => Private_Declarations (Sync_Def), 2247 D => Dom_Info); 2248 end Traverse_Sync_Definition; 2249 2250 -------------------------------------- 2251 -- Traverse_Subprogram_Or_Task_Body -- 2252 -------------------------------------- 2253 2254 procedure Traverse_Subprogram_Or_Task_Body 2255 (N : Node_Id; 2256 D : Dominant_Info := No_Dominant) 2257 is 2258 Decls : constant List_Id := Declarations (N); 2259 Dom_Info : Dominant_Info := D; 2260 begin 2261 -- If declarations are present, the first statement is dominated by the 2262 -- last declaration. 2263 2264 Dom_Info := Traverse_Declarations_Or_Statements 2265 (L => Decls, D => Dom_Info); 2266 2267 Traverse_Handled_Statement_Sequence 2268 (N => Handled_Statement_Sequence (N), 2269 D => Dom_Info); 2270 end Traverse_Subprogram_Or_Task_Body; 2271 2272end Par_SCO; 2273