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-2012, 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_Decl_Nodes 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 (Declarations (ADN)); 931 Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); 932 end Traverse_Aux_Decls; 933 934 -- Start of processing for SCO_Record 935 936 begin 937 -- Ignore call if not generating code and generating SCO's 938 939 if not (Generate_SCO and then Operating_Mode = Generate_Code) then 940 return; 941 end if; 942 943 -- Ignore call if this unit already recorded 944 945 for J in 1 .. SCO_Unit_Number_Table.Last loop 946 if U = SCO_Unit_Number_Table.Table (J) then 947 return; 948 end if; 949 end loop; 950 951 -- Otherwise record starting entry 952 953 From := SCO_Table.Last + 1; 954 955 -- Get Unit (checking case of subunit) 956 957 Lu := Unit (Cunit (U)); 958 959 if Nkind (Lu) = N_Subunit then 960 Lu := Proper_Body (Lu); 961 end if; 962 963 -- Traverse the unit 964 965 Traverse_Aux_Decls (Cunit (U)); 966 967 case Nkind (Lu) is 968 when 969 N_Package_Declaration | 970 N_Package_Body | 971 N_Subprogram_Declaration | 972 N_Subprogram_Body | 973 N_Generic_Package_Declaration | 974 N_Protected_Body | 975 N_Task_Body | 976 N_Generic_Instantiation => 977 978 Traverse_Declarations_Or_Statements (L => No_List, P => Lu); 979 980 when others => 981 982 -- All other cases of compilation units (e.g. renamings), generate 983 -- no SCO information. 984 985 null; 986 end case; 987 988 -- Make entry for new unit in unit tables, we will fill in the file 989 -- name and dependency numbers later. 990 991 SCO_Unit_Table.Append ( 992 (Dep_Num => 0, 993 File_Name => null, 994 From => From, 995 To => SCO_Table.Last)); 996 997 SCO_Unit_Number_Table.Append (U); 998 end SCO_Record; 999 1000 ----------------------- 1001 -- Set_SCO_Condition -- 1002 ----------------------- 1003 1004 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is 1005 Orig : constant Node_Id := Original_Node (Cond); 1006 Index : Nat; 1007 Start : Source_Ptr; 1008 Dummy : Source_Ptr; 1009 1010 Constant_Condition_Code : constant array (Boolean) of Character := 1011 (False => 'f', True => 't'); 1012 begin 1013 Sloc_Range (Orig, Start, Dummy); 1014 Index := Condition_Pragma_Hash_Table.Get (Start); 1015 1016 -- Index can be zero for boolean expressions that do not have SCOs 1017 -- (simple decisions outside of a control flow structure), or in case 1018 -- of a previous error. 1019 1020 if Index = 0 then 1021 return; 1022 1023 else 1024 pragma Assert (SCO_Table.Table (Index).C1 = ' '); 1025 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); 1026 end if; 1027 end Set_SCO_Condition; 1028 1029 ---------------------------- 1030 -- Set_SCO_Pragma_Enabled -- 1031 ---------------------------- 1032 1033 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is 1034 Index : Nat; 1035 1036 begin 1037 -- Nothing to do if not generating SCO, or if we're not processing the 1038 -- original source occurrence of the pragma. 1039 1040 if not (Generate_SCO 1041 and then In_Extended_Main_Source_Unit (Loc) 1042 and then not (In_Instance or In_Inlined_Body)) 1043 then 1044 return; 1045 end if; 1046 1047 -- Note: the reason we use the Sloc value as the key is that in the 1048 -- generic case, the call to this procedure is made on a copy of the 1049 -- original node, so we can't use the Node_Id value. 1050 1051 Index := Condition_Pragma_Hash_Table.Get (Loc); 1052 1053 -- A zero index here indicates that semantic analysis found an 1054 -- activated pragma at Loc which does not have a corresponding pragma 1055 -- or aspect at the syntax level. This may occur in legitimate cases 1056 -- because of expanded code (such are Pre/Post conditions generated for 1057 -- formal parameter validity checks), or as a consequence of a previous 1058 -- error. 1059 1060 if Index = 0 then 1061 return; 1062 1063 else 1064 declare 1065 T : SCO_Table_Entry renames SCO_Table.Table (Index); 1066 1067 begin 1068 -- Note: may be called multiple times for the same sloc, so 1069 -- account for the fact that the entry may already have been 1070 -- marked enabled. 1071 1072 case T.C1 is 1073 -- Aspect (decision SCO) 1074 1075 when 'a' => 1076 T.C1 := 'A'; 1077 1078 when 'A' => 1079 null; 1080 1081 -- Pragma (statement SCO) 1082 1083 when 'S' => 1084 pragma Assert (T.C2 = 'p' or else T.C2 = 'P'); 1085 T.C2 := 'P'; 1086 1087 when others => 1088 raise Program_Error; 1089 end case; 1090 end; 1091 end if; 1092 end Set_SCO_Pragma_Enabled; 1093 1094 --------------------- 1095 -- Set_Table_Entry -- 1096 --------------------- 1097 1098 procedure Set_Table_Entry 1099 (C1 : Character; 1100 C2 : Character; 1101 From : Source_Ptr; 1102 To : Source_Ptr; 1103 Last : Boolean; 1104 Pragma_Sloc : Source_Ptr := No_Location; 1105 Pragma_Aspect_Name : Name_Id := No_Name) 1106 is 1107 begin 1108 SCO_Table.Append 1109 ((C1 => C1, 1110 C2 => C2, 1111 From => To_Source_Location (From), 1112 To => To_Source_Location (To), 1113 Last => Last, 1114 Pragma_Sloc => Pragma_Sloc, 1115 Pragma_Aspect_Name => Pragma_Aspect_Name)); 1116 end Set_Table_Entry; 1117 1118 ------------------------ 1119 -- To_Source_Location -- 1120 ------------------------ 1121 1122 function To_Source_Location (S : Source_Ptr) return Source_Location is 1123 begin 1124 if S = No_Location then 1125 return No_Source_Location; 1126 else 1127 return 1128 (Line => Get_Logical_Line_Number (S), 1129 Col => Get_Column_Number (S)); 1130 end if; 1131 end To_Source_Location; 1132 1133 ----------------------------------------- 1134 -- Traverse_Declarations_Or_Statements -- 1135 ----------------------------------------- 1136 1137 -- Tables used by Traverse_Declarations_Or_Statements for temporarily 1138 -- holding statement and decision entries. These are declared globally 1139 -- since they are shared by recursive calls to this procedure. 1140 1141 type SC_Entry is record 1142 N : Node_Id; 1143 From : Source_Ptr; 1144 To : Source_Ptr; 1145 Typ : Character; 1146 end record; 1147 -- Used to store a single entry in the following table, From:To represents 1148 -- the range of entries in the CS line entry, and typ is the type, with 1149 -- space meaning that no type letter will accompany the entry. 1150 1151 package SC is new Table.Table ( 1152 Table_Component_Type => SC_Entry, 1153 Table_Index_Type => Nat, 1154 Table_Low_Bound => 1, 1155 Table_Initial => 1000, 1156 Table_Increment => 200, 1157 Table_Name => "SCO_SC"); 1158 -- Used to store statement components for a CS entry to be output 1159 -- as a result of the call to this procedure. SC.Last is the last 1160 -- entry stored, so the current statement sequence is represented 1161 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on 1162 -- entry to each recursive call to the routine. 1163 -- 1164 -- Extend_Statement_Sequence adds an entry to this array, and then 1165 -- Set_Statement_Entry clears the entries starting with SC_First, 1166 -- copying these entries to the main SCO output table. The reason that 1167 -- we do the temporary caching of results in this array is that we want 1168 -- the SCO table entries for a given CS line to be contiguous, and the 1169 -- processing may output intermediate entries such as decision entries. 1170 1171 type SD_Entry is record 1172 Nod : Node_Id; 1173 Lst : List_Id; 1174 Typ : Character; 1175 Plo : Source_Ptr; 1176 end record; 1177 -- Used to store a single entry in the following table. Nod is the node to 1178 -- be searched for decisions for the case of Process_Decisions_Defer with a 1179 -- node argument (with Lst set to No_List. Lst is the list to be searched 1180 -- for decisions for the case of Process_Decisions_Defer with a List 1181 -- argument (in which case Nod is set to Empty). Plo is the sloc of the 1182 -- enclosing pragma, if any. 1183 1184 package SD is new Table.Table ( 1185 Table_Component_Type => SD_Entry, 1186 Table_Index_Type => Nat, 1187 Table_Low_Bound => 1, 1188 Table_Initial => 1000, 1189 Table_Increment => 200, 1190 Table_Name => "SCO_SD"); 1191 -- Used to store possible decision information. Instead of calling the 1192 -- Process_Decisions procedures directly, we call Process_Decisions_Defer, 1193 -- which simply stores the arguments in this table. Then when we clear 1194 -- out a statement sequence using Set_Statement_Entry, after generating 1195 -- the CS lines for the statements, the entries in this table result in 1196 -- calls to Process_Decision. The reason for doing things this way is to 1197 -- ensure that decisions are output after the CS line for the statements 1198 -- in which the decisions occur. 1199 1200 procedure Traverse_Declarations_Or_Statements 1201 (L : List_Id; 1202 D : Dominant_Info := No_Dominant; 1203 P : Node_Id := Empty) 1204 is 1205 Discard_Dom : Dominant_Info; 1206 pragma Warnings (Off, Discard_Dom); 1207 begin 1208 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P); 1209 end Traverse_Declarations_Or_Statements; 1210 1211 function Traverse_Declarations_Or_Statements 1212 (L : List_Id; 1213 D : Dominant_Info := No_Dominant; 1214 P : Node_Id := Empty) return Dominant_Info 1215 is 1216 Current_Dominant : Dominant_Info := D; 1217 -- Dominance information for the current basic block 1218 1219 Current_Test : Node_Id; 1220 -- Conditional node (N_If_Statement or N_Elsiif being processed 1221 1222 N : Node_Id; 1223 1224 SC_First : constant Nat := SC.Last + 1; 1225 SD_First : constant Nat := SD.Last + 1; 1226 -- Record first entries used in SC/SD at this recursive level 1227 1228 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); 1229 -- Extend the current statement sequence to encompass the node N. Typ 1230 -- is the letter that identifies the type of statement/declaration that 1231 -- is being added to the sequence. 1232 1233 procedure Set_Statement_Entry; 1234 -- Output CS entries for all statements saved in table SC, and end the 1235 -- current CS sequence. Then output entries for all decisions nested in 1236 -- these statements, which have been deferred so far. 1237 1238 procedure Process_Decisions_Defer (N : Node_Id; T : Character); 1239 pragma Inline (Process_Decisions_Defer); 1240 -- This routine is logically the same as Process_Decisions, except that 1241 -- the arguments are saved in the SD table for later processing when 1242 -- Set_Statement_Entry is called, which goes through the saved entries 1243 -- making the corresponding calls to Process_Decision. 1244 1245 procedure Process_Decisions_Defer (L : List_Id; T : Character); 1246 pragma Inline (Process_Decisions_Defer); 1247 -- Same case for list arguments, deferred call to Process_Decisions 1248 1249 procedure Traverse_One (N : Node_Id); 1250 -- Traverse one declaration or statement 1251 1252 procedure Traverse_Aspects (N : Node_Id); 1253 -- Helper for Traverse_One: traverse N's aspect specifications 1254 1255 ------------------------- 1256 -- Set_Statement_Entry -- 1257 ------------------------- 1258 1259 procedure Set_Statement_Entry is 1260 SC_Last : constant Int := SC.Last; 1261 SD_Last : constant Int := SD.Last; 1262 1263 begin 1264 -- Output statement entries from saved entries in SC table 1265 1266 for J in SC_First .. SC_Last loop 1267 if J = SC_First then 1268 1269 if Current_Dominant /= No_Dominant then 1270 declare 1271 From, To : Source_Ptr; 1272 begin 1273 Sloc_Range (Current_Dominant.N, From, To); 1274 if Current_Dominant.K /= 'E' then 1275 To := No_Location; 1276 end if; 1277 Set_Table_Entry 1278 (C1 => '>', 1279 C2 => Current_Dominant.K, 1280 From => From, 1281 To => To, 1282 Last => False, 1283 Pragma_Sloc => No_Location, 1284 Pragma_Aspect_Name => No_Name); 1285 end; 1286 end if; 1287 end if; 1288 1289 declare 1290 SCE : SC_Entry renames SC.Table (J); 1291 Pragma_Sloc : Source_Ptr := No_Location; 1292 Pragma_Aspect_Name : Name_Id := No_Name; 1293 begin 1294 -- For the case of a statement SCO for a pragma controlled by 1295 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and 1296 -- those of any nested decision) is emitted only if the pragma 1297 -- is enabled. 1298 1299 if SCE.Typ = 'p' then 1300 Pragma_Sloc := SCE.From; 1301 Condition_Pragma_Hash_Table.Set 1302 (Pragma_Sloc, SCO_Table.Last + 1); 1303 Pragma_Aspect_Name := Pragma_Name (SCE.N); 1304 pragma Assert (Pragma_Aspect_Name /= No_Name); 1305 1306 elsif SCE.Typ = 'P' then 1307 Pragma_Aspect_Name := Pragma_Name (SCE.N); 1308 pragma Assert (Pragma_Aspect_Name /= No_Name); 1309 end if; 1310 1311 Set_Table_Entry 1312 (C1 => 'S', 1313 C2 => SCE.Typ, 1314 From => SCE.From, 1315 To => SCE.To, 1316 Last => (J = SC_Last), 1317 Pragma_Sloc => Pragma_Sloc, 1318 Pragma_Aspect_Name => Pragma_Aspect_Name); 1319 end; 1320 end loop; 1321 1322 -- Last statement of basic block, if present, becomes new current 1323 -- dominant. 1324 1325 if SC_Last >= SC_First then 1326 Current_Dominant := ('S', SC.Table (SC_Last).N); 1327 end if; 1328 1329 -- Clear out used section of SC table 1330 1331 SC.Set_Last (SC_First - 1); 1332 1333 -- Output any embedded decisions 1334 1335 for J in SD_First .. SD_Last loop 1336 declare 1337 SDE : SD_Entry renames SD.Table (J); 1338 begin 1339 if Present (SDE.Nod) then 1340 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); 1341 else 1342 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); 1343 end if; 1344 end; 1345 end loop; 1346 1347 -- Clear out used section of SD table 1348 1349 SD.Set_Last (SD_First - 1); 1350 end Set_Statement_Entry; 1351 1352 ------------------------------- 1353 -- Extend_Statement_Sequence -- 1354 ------------------------------- 1355 1356 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is 1357 F : Source_Ptr; 1358 T : Source_Ptr; 1359 Dummy : Source_Ptr; 1360 To_Node : Node_Id := Empty; 1361 1362 begin 1363 Sloc_Range (N, F, T); 1364 1365 case Nkind (N) is 1366 when N_Accept_Statement => 1367 if Present (Parameter_Specifications (N)) then 1368 To_Node := Last (Parameter_Specifications (N)); 1369 elsif Present (Entry_Index (N)) then 1370 To_Node := Entry_Index (N); 1371 end if; 1372 1373 when N_Case_Statement => 1374 To_Node := Expression (N); 1375 1376 when N_If_Statement | N_Elsif_Part => 1377 To_Node := Condition (N); 1378 1379 when N_Extended_Return_Statement => 1380 To_Node := Last (Return_Object_Declarations (N)); 1381 1382 when N_Loop_Statement => 1383 To_Node := Iteration_Scheme (N); 1384 1385 when N_Selective_Accept | 1386 N_Timed_Entry_Call | 1387 N_Conditional_Entry_Call | 1388 N_Asynchronous_Select | 1389 N_Single_Protected_Declaration | 1390 N_Single_Task_Declaration => 1391 T := F; 1392 1393 when N_Protected_Type_Declaration | N_Task_Type_Declaration => 1394 if Has_Aspects (N) then 1395 To_Node := Last (Aspect_Specifications (N)); 1396 1397 elsif Present (Discriminant_Specifications (N)) then 1398 To_Node := Last (Discriminant_Specifications (N)); 1399 1400 else 1401 To_Node := Defining_Identifier (N); 1402 end if; 1403 1404 when others => 1405 null; 1406 1407 end case; 1408 1409 if Present (To_Node) then 1410 Sloc_Range (To_Node, Dummy, T); 1411 end if; 1412 1413 SC.Append ((N, F, T, Typ)); 1414 end Extend_Statement_Sequence; 1415 1416 ----------------------------- 1417 -- Process_Decisions_Defer -- 1418 ----------------------------- 1419 1420 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is 1421 begin 1422 SD.Append ((N, No_List, T, Current_Pragma_Sloc)); 1423 end Process_Decisions_Defer; 1424 1425 procedure Process_Decisions_Defer (L : List_Id; T : Character) is 1426 begin 1427 SD.Append ((Empty, L, T, Current_Pragma_Sloc)); 1428 end Process_Decisions_Defer; 1429 1430 ---------------------- 1431 -- Traverse_Aspects -- 1432 ---------------------- 1433 1434 procedure Traverse_Aspects (N : Node_Id) is 1435 AN : Node_Id; 1436 AE : Node_Id; 1437 C1 : Character; 1438 1439 begin 1440 AN := First (Aspect_Specifications (N)); 1441 while Present (AN) loop 1442 AE := Expression (AN); 1443 1444 -- SCOs are generated before semantic analysis/expansion: 1445 -- PPCs are not split yet. 1446 1447 pragma Assert (not Split_PPC (AN)); 1448 1449 C1 := ASCII.NUL; 1450 1451 case Get_Aspect_Id (Chars (Identifier (AN))) is 1452 1453 -- Aspects rewritten into pragmas controlled by a Check_Policy: 1454 -- Current_Pragma_Sloc must be set to the sloc of the aspect 1455 -- specification. The corresponding pragma will have the same 1456 -- sloc. 1457 1458 when Aspect_Pre | 1459 Aspect_Precondition | 1460 Aspect_Post | 1461 Aspect_Postcondition | 1462 Aspect_Invariant => 1463 1464 C1 := 'a'; 1465 1466 -- Aspects whose checks are generated in client units, 1467 -- regardless of whether or not the check is activated in the 1468 -- unit which contains the declaration: create decision as 1469 -- unconditionally enabled aspect (but still make a pragma 1470 -- entry since Set_SCO_Pragma_Enabled will be called when 1471 -- analyzing actual checks, possibly in other units). 1472 1473 -- Pre/post can have checks in client units too because of 1474 -- inheritance, so should they be moved here??? 1475 1476 when Aspect_Predicate | 1477 Aspect_Static_Predicate | 1478 Aspect_Dynamic_Predicate | 1479 Aspect_Type_Invariant => 1480 1481 C1 := 'A'; 1482 1483 -- Other aspects: just process any decision nested in the 1484 -- aspect expression. 1485 1486 when others => 1487 1488 if Has_Decision (AE) then 1489 C1 := 'X'; 1490 end if; 1491 1492 end case; 1493 1494 if C1 /= ASCII.NUL then 1495 pragma Assert (Current_Pragma_Sloc = No_Location); 1496 1497 if C1 = 'a' or else C1 = 'A' then 1498 Current_Pragma_Sloc := Sloc (AN); 1499 end if; 1500 1501 Process_Decisions_Defer (AE, C1); 1502 1503 Current_Pragma_Sloc := No_Location; 1504 end if; 1505 1506 Next (AN); 1507 end loop; 1508 end Traverse_Aspects; 1509 1510 ------------------ 1511 -- Traverse_One -- 1512 ------------------ 1513 1514 procedure Traverse_One (N : Node_Id) is 1515 begin 1516 -- Initialize or extend current statement sequence. Note that for 1517 -- special cases such as IF and Case statements we will modify 1518 -- the range to exclude internal statements that should not be 1519 -- counted as part of the current statement sequence. 1520 1521 case Nkind (N) is 1522 1523 -- Package declaration 1524 1525 when N_Package_Declaration => 1526 Set_Statement_Entry; 1527 Traverse_Package_Declaration (N, Current_Dominant); 1528 1529 -- Generic package declaration 1530 1531 when N_Generic_Package_Declaration => 1532 Set_Statement_Entry; 1533 Traverse_Generic_Package_Declaration (N); 1534 1535 -- Package body 1536 1537 when N_Package_Body => 1538 Set_Statement_Entry; 1539 Traverse_Package_Body (N); 1540 1541 -- Subprogram declaration 1542 1543 when N_Subprogram_Declaration | N_Subprogram_Body_Stub => 1544 Process_Decisions_Defer 1545 (Parameter_Specifications (Specification (N)), 'X'); 1546 1547 -- Generic subprogram declaration 1548 1549 when N_Generic_Subprogram_Declaration => 1550 Process_Decisions_Defer 1551 (Generic_Formal_Declarations (N), 'X'); 1552 Process_Decisions_Defer 1553 (Parameter_Specifications (Specification (N)), 'X'); 1554 1555 -- Task or subprogram body 1556 1557 when N_Task_Body | N_Subprogram_Body => 1558 Set_Statement_Entry; 1559 Traverse_Subprogram_Or_Task_Body (N); 1560 1561 -- Entry body 1562 1563 when N_Entry_Body => 1564 declare 1565 Cond : constant Node_Id := 1566 Condition (Entry_Body_Formal_Part (N)); 1567 1568 Inner_Dominant : Dominant_Info := No_Dominant; 1569 1570 begin 1571 Set_Statement_Entry; 1572 1573 if Present (Cond) then 1574 Process_Decisions_Defer (Cond, 'G'); 1575 1576 -- For an entry body with a barrier, the entry body 1577 -- is dominanted by a True evaluation of the barrier. 1578 1579 Inner_Dominant := ('T', N); 1580 end if; 1581 1582 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); 1583 end; 1584 1585 -- Protected body 1586 1587 when N_Protected_Body => 1588 Set_Statement_Entry; 1589 Traverse_Declarations_Or_Statements (Declarations (N)); 1590 1591 -- Exit statement, which is an exit statement in the SCO sense, 1592 -- so it is included in the current statement sequence, but 1593 -- then it terminates this sequence. We also have to process 1594 -- any decisions in the exit statement expression. 1595 1596 when N_Exit_Statement => 1597 Extend_Statement_Sequence (N, ' '); 1598 Process_Decisions_Defer (Condition (N), 'E'); 1599 Set_Statement_Entry; 1600 1601 -- If condition is present, then following statement is 1602 -- only executed if the condition evaluates to False. 1603 1604 if Present (Condition (N)) then 1605 Current_Dominant := ('F', N); 1606 else 1607 Current_Dominant := No_Dominant; 1608 end if; 1609 1610 -- Label, which breaks the current statement sequence, but the 1611 -- label itself is not included in the next statement sequence, 1612 -- since it generates no code. 1613 1614 when N_Label => 1615 Set_Statement_Entry; 1616 Current_Dominant := No_Dominant; 1617 1618 -- Block statement, which breaks the current statement sequence 1619 1620 when N_Block_Statement => 1621 Set_Statement_Entry; 1622 1623 -- The first statement in the handled sequence of statements 1624 -- is dominated by the elaboration of the last declaration. 1625 1626 Current_Dominant := Traverse_Declarations_Or_Statements 1627 (L => Declarations (N), 1628 D => Current_Dominant); 1629 1630 Traverse_Handled_Statement_Sequence 1631 (N => Handled_Statement_Sequence (N), 1632 D => Current_Dominant); 1633 1634 -- If statement, which breaks the current statement sequence, 1635 -- but we include the condition in the current sequence. 1636 1637 when N_If_Statement => 1638 Current_Test := N; 1639 Extend_Statement_Sequence (N, 'I'); 1640 Process_Decisions_Defer (Condition (N), 'I'); 1641 Set_Statement_Entry; 1642 1643 -- Now we traverse the statements in the THEN part 1644 1645 Traverse_Declarations_Or_Statements 1646 (L => Then_Statements (N), 1647 D => ('T', N)); 1648 1649 -- Loop through ELSIF parts if present 1650 1651 if Present (Elsif_Parts (N)) then 1652 declare 1653 Saved_Dominant : constant Dominant_Info := 1654 Current_Dominant; 1655 1656 Elif : Node_Id := First (Elsif_Parts (N)); 1657 1658 begin 1659 while Present (Elif) loop 1660 1661 -- An Elsif is executed only if the previous test 1662 -- got a FALSE outcome. 1663 1664 Current_Dominant := ('F', Current_Test); 1665 1666 -- Now update current test information 1667 1668 Current_Test := Elif; 1669 1670 -- We generate a statement sequence for the 1671 -- construct "ELSIF condition", so that we have 1672 -- a statement for the resulting decisions. 1673 1674 Extend_Statement_Sequence (Elif, 'I'); 1675 Process_Decisions_Defer (Condition (Elif), 'I'); 1676 Set_Statement_Entry; 1677 1678 -- An ELSIF part is never guaranteed to have 1679 -- been executed, following statements are only 1680 -- dominated by the initial IF statement. 1681 1682 Current_Dominant := Saved_Dominant; 1683 1684 -- Traverse the statements in the ELSIF 1685 1686 Traverse_Declarations_Or_Statements 1687 (L => Then_Statements (Elif), 1688 D => ('T', Elif)); 1689 Next (Elif); 1690 end loop; 1691 end; 1692 end if; 1693 1694 -- Finally traverse the ELSE statements if present 1695 1696 Traverse_Declarations_Or_Statements 1697 (L => Else_Statements (N), 1698 D => ('F', Current_Test)); 1699 1700 -- CASE statement, which breaks the current statement sequence, 1701 -- but we include the expression in the current sequence. 1702 1703 when N_Case_Statement => 1704 Extend_Statement_Sequence (N, 'C'); 1705 Process_Decisions_Defer (Expression (N), 'X'); 1706 Set_Statement_Entry; 1707 1708 -- Process case branches, all of which are dominated by the 1709 -- CASE statement. 1710 1711 declare 1712 Alt : Node_Id; 1713 begin 1714 Alt := First (Alternatives (N)); 1715 while Present (Alt) loop 1716 Traverse_Declarations_Or_Statements 1717 (L => Statements (Alt), 1718 D => Current_Dominant); 1719 Next (Alt); 1720 end loop; 1721 end; 1722 1723 -- ACCEPT statement 1724 1725 when N_Accept_Statement => 1726 Extend_Statement_Sequence (N, 'A'); 1727 Set_Statement_Entry; 1728 1729 -- Process sequence of statements, dominant is the ACCEPT 1730 -- statement. 1731 1732 Traverse_Handled_Statement_Sequence 1733 (N => Handled_Statement_Sequence (N), 1734 D => Current_Dominant); 1735 1736 -- SELECT 1737 1738 when N_Selective_Accept => 1739 Extend_Statement_Sequence (N, 'S'); 1740 Set_Statement_Entry; 1741 1742 -- Process alternatives 1743 1744 declare 1745 Alt : Node_Id; 1746 Guard : Node_Id; 1747 S_Dom : Dominant_Info; 1748 1749 begin 1750 Alt := First (Select_Alternatives (N)); 1751 while Present (Alt) loop 1752 S_Dom := Current_Dominant; 1753 Guard := Condition (Alt); 1754 1755 if Present (Guard) then 1756 Process_Decisions 1757 (Guard, 1758 'G', 1759 Pragma_Sloc => No_Location); 1760 Current_Dominant := ('T', Guard); 1761 end if; 1762 1763 Traverse_One (Alt); 1764 1765 Current_Dominant := S_Dom; 1766 Next (Alt); 1767 end loop; 1768 end; 1769 1770 Traverse_Declarations_Or_Statements 1771 (L => Else_Statements (N), 1772 D => Current_Dominant); 1773 1774 when N_Timed_Entry_Call | N_Conditional_Entry_Call => 1775 Extend_Statement_Sequence (N, 'S'); 1776 Set_Statement_Entry; 1777 1778 -- Process alternatives 1779 1780 Traverse_One (Entry_Call_Alternative (N)); 1781 1782 if Nkind (N) = N_Timed_Entry_Call then 1783 Traverse_One (Delay_Alternative (N)); 1784 else 1785 Traverse_Declarations_Or_Statements 1786 (L => Else_Statements (N), 1787 D => Current_Dominant); 1788 end if; 1789 1790 when N_Asynchronous_Select => 1791 Extend_Statement_Sequence (N, 'S'); 1792 Set_Statement_Entry; 1793 1794 Traverse_One (Triggering_Alternative (N)); 1795 Traverse_Declarations_Or_Statements 1796 (L => Statements (Abortable_Part (N)), 1797 D => Current_Dominant); 1798 1799 when N_Accept_Alternative => 1800 Traverse_Declarations_Or_Statements 1801 (L => Statements (N), 1802 D => Current_Dominant, 1803 P => Accept_Statement (N)); 1804 1805 when N_Entry_Call_Alternative => 1806 Traverse_Declarations_Or_Statements 1807 (L => Statements (N), 1808 D => Current_Dominant, 1809 P => Entry_Call_Statement (N)); 1810 1811 when N_Delay_Alternative => 1812 Traverse_Declarations_Or_Statements 1813 (L => Statements (N), 1814 D => Current_Dominant, 1815 P => Delay_Statement (N)); 1816 1817 when N_Triggering_Alternative => 1818 Traverse_Declarations_Or_Statements 1819 (L => Statements (N), 1820 D => Current_Dominant, 1821 P => Triggering_Statement (N)); 1822 1823 when N_Terminate_Alternative => 1824 1825 -- It is dubious to emit a statement SCO for a TERMINATE 1826 -- alternative, since no code is actually executed if the 1827 -- alternative is selected -- the tasking runtime call just 1828 -- never returns??? 1829 1830 Extend_Statement_Sequence (N, ' '); 1831 Set_Statement_Entry; 1832 1833 -- Unconditional exit points, which are included in the current 1834 -- statement sequence, but then terminate it 1835 1836 when N_Requeue_Statement | 1837 N_Goto_Statement | 1838 N_Raise_Statement => 1839 Extend_Statement_Sequence (N, ' '); 1840 Set_Statement_Entry; 1841 Current_Dominant := No_Dominant; 1842 1843 -- Simple return statement. which is an exit point, but we 1844 -- have to process the return expression for decisions. 1845 1846 when N_Simple_Return_Statement => 1847 Extend_Statement_Sequence (N, ' '); 1848 Process_Decisions_Defer (Expression (N), 'X'); 1849 Set_Statement_Entry; 1850 Current_Dominant := No_Dominant; 1851 1852 -- Extended return statement 1853 1854 when N_Extended_Return_Statement => 1855 Extend_Statement_Sequence (N, 'R'); 1856 Process_Decisions_Defer 1857 (Return_Object_Declarations (N), 'X'); 1858 Set_Statement_Entry; 1859 1860 Traverse_Handled_Statement_Sequence 1861 (N => Handled_Statement_Sequence (N), 1862 D => Current_Dominant); 1863 1864 Current_Dominant := No_Dominant; 1865 1866 -- Loop ends the current statement sequence, but we include 1867 -- the iteration scheme if present in the current sequence. 1868 -- But the body of the loop starts a new sequence, since it 1869 -- may not be executed as part of the current sequence. 1870 1871 when N_Loop_Statement => 1872 declare 1873 ISC : constant Node_Id := Iteration_Scheme (N); 1874 Inner_Dominant : Dominant_Info := No_Dominant; 1875 1876 begin 1877 if Present (ISC) then 1878 1879 -- If iteration scheme present, extend the current 1880 -- statement sequence to include the iteration scheme 1881 -- and process any decisions it contains. 1882 1883 -- While loop 1884 1885 if Present (Condition (ISC)) then 1886 Extend_Statement_Sequence (N, 'W'); 1887 Process_Decisions_Defer (Condition (ISC), 'W'); 1888 1889 -- Set more specific dominant for inner statements 1890 -- (the control sloc for the decision is that of 1891 -- the WHILE token). 1892 1893 Inner_Dominant := ('T', ISC); 1894 1895 -- For loop 1896 1897 else 1898 Extend_Statement_Sequence (N, 'F'); 1899 Process_Decisions_Defer 1900 (Loop_Parameter_Specification (ISC), 'X'); 1901 end if; 1902 end if; 1903 1904 Set_Statement_Entry; 1905 1906 if Inner_Dominant = No_Dominant then 1907 Inner_Dominant := Current_Dominant; 1908 end if; 1909 1910 Traverse_Declarations_Or_Statements 1911 (L => Statements (N), 1912 D => Inner_Dominant); 1913 end; 1914 1915 -- Pragma 1916 1917 when N_Pragma => 1918 1919 -- Record sloc of pragma (pragmas don't nest) 1920 1921 pragma Assert (Current_Pragma_Sloc = No_Location); 1922 Current_Pragma_Sloc := Sloc (N); 1923 1924 -- Processing depends on the kind of pragma 1925 1926 declare 1927 Nam : constant Name_Id := Pragma_Name (N); 1928 Arg : Node_Id := 1929 First (Pragma_Argument_Associations (N)); 1930 Typ : Character; 1931 1932 begin 1933 case Nam is 1934 when Name_Assert | 1935 Name_Assert_And_Cut | 1936 Name_Assume | 1937 Name_Check | 1938 Name_Loop_Invariant | 1939 Name_Precondition | 1940 Name_Postcondition => 1941 1942 -- For Assert/Check/Precondition/Postcondition, we 1943 -- must generate a P entry for the decision. Note 1944 -- that this is done unconditionally at this stage. 1945 -- Output for disabled pragmas is suppressed later 1946 -- on when we output the decision line in Put_SCOs, 1947 -- depending on setting by Set_SCO_Pragma_Enabled. 1948 1949 if Nam = Name_Check then 1950 Next (Arg); 1951 end if; 1952 1953 Process_Decisions_Defer (Expression (Arg), 'P'); 1954 Typ := 'p'; 1955 1956 -- Pre/postconditions can be inherited so SCO should 1957 -- never be deactivated??? 1958 1959 when Name_Debug => 1960 if Present (Arg) and then Present (Next (Arg)) then 1961 1962 -- Case of a dyadic pragma Debug: first argument 1963 -- is a P decision, any nested decision in the 1964 -- second argument is an X decision. 1965 1966 Process_Decisions_Defer (Expression (Arg), 'P'); 1967 Next (Arg); 1968 end if; 1969 1970 Process_Decisions_Defer (Expression (Arg), 'X'); 1971 Typ := 'p'; 1972 1973 -- For all other pragmas, we generate decision entries 1974 -- for any embedded expressions, and the pragma is 1975 -- never disabled. 1976 1977 -- Should generate P decisions (not X) for assertion 1978 -- related pragmas: [Type_]Invariant, 1979 -- [{Static,Dynamic}_]Predicate??? 1980 1981 when others => 1982 Process_Decisions_Defer (N, 'X'); 1983 Typ := 'P'; 1984 end case; 1985 1986 -- Add statement SCO 1987 1988 Extend_Statement_Sequence (N, Typ); 1989 1990 Current_Pragma_Sloc := No_Location; 1991 end; 1992 1993 -- Object declaration. Ignored if Prev_Ids is set, since the 1994 -- parser generates multiple instances of the whole declaration 1995 -- if there is more than one identifier declared, and we only 1996 -- want one entry in the SCOs, so we take the first, for which 1997 -- Prev_Ids is False. 1998 1999 when N_Object_Declaration => 2000 if not Prev_Ids (N) then 2001 Extend_Statement_Sequence (N, 'o'); 2002 2003 if Has_Decision (N) then 2004 Process_Decisions_Defer (N, 'X'); 2005 end if; 2006 end if; 2007 2008 -- All other cases, which extend the current statement sequence 2009 -- but do not terminate it, even if they have nested decisions. 2010 2011 when N_Protected_Type_Declaration | N_Task_Type_Declaration => 2012 Extend_Statement_Sequence (N, 't'); 2013 Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); 2014 Set_Statement_Entry; 2015 2016 Traverse_Sync_Definition (N); 2017 2018 when N_Single_Protected_Declaration | N_Single_Task_Declaration => 2019 Extend_Statement_Sequence (N, 'o'); 2020 Set_Statement_Entry; 2021 2022 Traverse_Sync_Definition (N); 2023 2024 when others => 2025 2026 -- Determine required type character code, or ASCII.NUL if 2027 -- no SCO should be generated for this node. 2028 2029 declare 2030 Typ : Character; 2031 2032 begin 2033 case Nkind (N) is 2034 when N_Full_Type_Declaration | 2035 N_Incomplete_Type_Declaration | 2036 N_Private_Type_Declaration | 2037 N_Private_Extension_Declaration => 2038 Typ := 't'; 2039 2040 when N_Subtype_Declaration => 2041 Typ := 's'; 2042 2043 when N_Renaming_Declaration => 2044 Typ := 'r'; 2045 2046 when N_Generic_Instantiation => 2047 Typ := 'i'; 2048 2049 when N_Representation_Clause | 2050 N_Use_Package_Clause | 2051 N_Use_Type_Clause | 2052 N_Package_Body_Stub | 2053 N_Task_Body_Stub | 2054 N_Protected_Body_Stub => 2055 Typ := ASCII.NUL; 2056 2057 when others => 2058 Typ := ' '; 2059 end case; 2060 2061 if Typ /= ASCII.NUL then 2062 Extend_Statement_Sequence (N, Typ); 2063 end if; 2064 end; 2065 2066 -- Process any embedded decisions 2067 2068 if Has_Decision (N) then 2069 Process_Decisions_Defer (N, 'X'); 2070 end if; 2071 end case; 2072 2073 -- Process aspects if present 2074 2075 Traverse_Aspects (N); 2076 end Traverse_One; 2077 2078 -- Start of processing for Traverse_Declarations_Or_Statements 2079 2080 begin 2081 -- Process single prefixed node 2082 2083 if Present (P) then 2084 Traverse_One (P); 2085 end if; 2086 2087 -- Loop through statements or declarations 2088 2089 if Is_Non_Empty_List (L) then 2090 N := First (L); 2091 while Present (N) loop 2092 Traverse_One (N); 2093 Next (N); 2094 end loop; 2095 2096 end if; 2097 2098 -- End sequence of statements and flush deferred decisions 2099 2100 if Present (P) or else Is_Non_Empty_List (L) then 2101 Set_Statement_Entry; 2102 end if; 2103 2104 return Current_Dominant; 2105 end Traverse_Declarations_Or_Statements; 2106 2107 ------------------------------------------ 2108 -- Traverse_Generic_Package_Declaration -- 2109 ------------------------------------------ 2110 2111 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is 2112 begin 2113 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); 2114 Traverse_Package_Declaration (N); 2115 end Traverse_Generic_Package_Declaration; 2116 2117 ----------------------------------------- 2118 -- Traverse_Handled_Statement_Sequence -- 2119 ----------------------------------------- 2120 2121 procedure Traverse_Handled_Statement_Sequence 2122 (N : Node_Id; 2123 D : Dominant_Info := No_Dominant) 2124 is 2125 Handler : Node_Id; 2126 2127 begin 2128 -- For package bodies without a statement part, the parser adds an empty 2129 -- one, to normalize the representation. The null statement therein, 2130 -- which does not come from source, does not get a SCO. 2131 2132 if Present (N) and then Comes_From_Source (N) then 2133 Traverse_Declarations_Or_Statements (Statements (N), D); 2134 2135 if Present (Exception_Handlers (N)) then 2136 Handler := First (Exception_Handlers (N)); 2137 while Present (Handler) loop 2138 Traverse_Declarations_Or_Statements 2139 (L => Statements (Handler), 2140 D => ('E', Handler)); 2141 Next (Handler); 2142 end loop; 2143 end if; 2144 end if; 2145 end Traverse_Handled_Statement_Sequence; 2146 2147 --------------------------- 2148 -- Traverse_Package_Body -- 2149 --------------------------- 2150 2151 procedure Traverse_Package_Body (N : Node_Id) is 2152 Dom : Dominant_Info; 2153 begin 2154 -- The first statement in the handled sequence of statements is 2155 -- dominated by the elaboration of the last declaration. 2156 2157 Dom := Traverse_Declarations_Or_Statements (Declarations (N)); 2158 2159 Traverse_Handled_Statement_Sequence 2160 (Handled_Statement_Sequence (N), Dom); 2161 end Traverse_Package_Body; 2162 2163 ---------------------------------- 2164 -- Traverse_Package_Declaration -- 2165 ---------------------------------- 2166 2167 procedure Traverse_Package_Declaration 2168 (N : Node_Id; 2169 D : Dominant_Info := No_Dominant) 2170 is 2171 Spec : constant Node_Id := Specification (N); 2172 Dom : Dominant_Info; 2173 2174 begin 2175 Dom := 2176 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D); 2177 2178 -- First private declaration is dominated by last visible declaration 2179 2180 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); 2181 end Traverse_Package_Declaration; 2182 2183 ------------------------------ 2184 -- Traverse_Sync_Definition -- 2185 ------------------------------ 2186 2187 procedure Traverse_Sync_Definition (N : Node_Id) is 2188 Dom_Info : Dominant_Info := ('S', N); 2189 -- The first declaration is dominated by the protected or task [type] 2190 -- declaration. 2191 2192 Sync_Def : Node_Id; 2193 -- N's protected or task definition 2194 2195 Vis_Decl : List_Id; 2196 -- Sync_Def's Visible_Declarations 2197 2198 begin 2199 case Nkind (N) is 2200 when N_Single_Protected_Declaration | N_Protected_Type_Declaration => 2201 Sync_Def := Protected_Definition (N); 2202 2203 when N_Single_Task_Declaration | N_Task_Type_Declaration => 2204 Sync_Def := Task_Definition (N); 2205 2206 when others => 2207 raise Program_Error; 2208 end case; 2209 2210 Vis_Decl := Visible_Declarations (Sync_Def); 2211 2212 Dom_Info := Traverse_Declarations_Or_Statements 2213 (L => Vis_Decl, 2214 D => Dom_Info); 2215 2216 -- If visible declarations are present, the first private declaration 2217 -- is dominated by the last visible declaration. 2218 2219 Traverse_Declarations_Or_Statements 2220 (L => Private_Declarations (Sync_Def), 2221 D => Dom_Info); 2222 end Traverse_Sync_Definition; 2223 2224 -------------------------------------- 2225 -- Traverse_Subprogram_Or_Task_Body -- 2226 -------------------------------------- 2227 2228 procedure Traverse_Subprogram_Or_Task_Body 2229 (N : Node_Id; 2230 D : Dominant_Info := No_Dominant) 2231 is 2232 Decls : constant List_Id := Declarations (N); 2233 Dom_Info : Dominant_Info := D; 2234 begin 2235 -- If declarations are present, the first statement is dominated by the 2236 -- last declaration. 2237 2238 Dom_Info := Traverse_Declarations_Or_Statements 2239 (L => Decls, D => Dom_Info); 2240 2241 Traverse_Handled_Statement_Sequence 2242 (N => Handled_Statement_Sequence (N), 2243 D => Dom_Info); 2244 end Traverse_Subprogram_Or_Task_Body; 2245 2246end Par_SCO; 2247