Changeset 2620
- Timestamp:
- 02/07/08 17:21:19 (1 year ago)
- Files:
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/tendra/src/producers/ada/asis/asis-compilation_units-relations.adb
r2617 r2620 10 10 -- Procedural wrapper over Object-Oriented ASIS implementation 11 11 12 ------------------------------------------------------------------------------ 13 -- Implementation restriction -- 14 -- not implemented Inconsistent list generation -- 15 ------------------------------------------------------------------------------ 16 12 17 with Asis.Errors; use Asis.Errors; 13 18 with Asis.Exceptions; … … 92 97 return Tree_Node_Access; 93 98 94 function Close_Find 95 (This : in Tree_Node; 96 Unit : in Compilation_Unit) 97 return Tree_Node_Access; 98 99 type Orders is (From_Child, From_Parent); 99 type Orders is (Ascending, Descending); 100 101 procedure Check 102 (This : in Tree_Node_Access; 103 Order : in Orders); 100 104 101 105 function Generate_Relationship 102 (This : in Tree_Node_Access; 103 Order : in Orders) 106 (This : in Tree_Node_Access; 107 Limit_List : in Utils.Compilation_Unit_List_Access; 108 List_Last : in ASIS_Integer; 109 Order : in Orders) 104 110 return Relationship; 105 111 … … 129 135 Unit : Compilation_Unit := Nil_Compilation_Unit; 130 136 Unit_Body : Compilation_Unit := Nil_Compilation_Unit; 137 138 Added : Boolean := False; 139 Consistent : Boolean := True; 131 140 132 141 -- пПÑлеЎÑÑÑОе елеЌеМÑÑ 0-Ñ … … 150 159 Units : Unit_Node_Array_Access := null; 151 160 161 -- ÑпОÑПк ÑОклОÑеÑÐºÐžÑ 162 завОÑОЌПÑÑей 152 163 Circular : Compilation_Unit_List_Access := null; 153 164 Circular_Added : Boolean := False; 154 165 166 -- ÑпОÑПк пÑПпавÑÐžÑ 167 ÑМОÑПв 155 168 Missing : Compilation_Unit_List_Access := null; 156 169 Missing_Added : Boolean := False; 157 170 158 Added : Boolean := False; 171 -- ÑпОÑПк МеÑПглаÑÑПваММÑÑ 172 ÑМОÑПв 173 Inconsistent : Compilation_Unit_List_Access := null; 174 Inconsistent_Added : Boolean := False; 159 175 end record; 160 176 161 177 procedure Finalize 162 178 (This : in out Tree_Node); 179 180 function Set_Inconsistent 181 (This : in Tree_Node_Access; 182 List : in Compilation_Unit_List_Access; 183 Order : in Orders) 184 return Compilation_Unit_List_Access; 163 185 164 186 procedure Deallocate is … … 191 213 return Integer; 192 214 215 function Is_Inconsistent 216 (Unit : in Compilation_Unit) 217 return Boolean; 218 219 function Is_Source_Changed 220 (Unit : in Compilation_Unit) 221 return Boolean; 222 193 223 end Utils; 194 224 … … 203 233 204 234 function Get_Descendants 235 (List : in Asis.Compilation_Unit_List; 236 The_Context : in Asis.Context) 237 return Utils.Tree_Node_Access; 238 239 function Get_Supporters 205 240 (List : in Asis.Compilation_Unit_List; 206 241 The_Context : in Asis.Context) … … 302 337 end Normalize; 303 338 304 Tree : Utils.Tree_Node_Access := null; 305 Result : Relationship := Nil_Relationship; 339 Tree : Utils.Tree_Node_Access := null; 340 341 procedure Clear is 342 begin 343 Deallocate (Tree); 344 Utils.Deallocate (Normalized_Compilation_Units); 345 Utils.Deallocate (Normalized_Dependent_Units); 346 end Clear; 347 306 348 begin 307 349 if Compilation_Units = Nil_Compilation_Unit_List then … … 348 390 The_Context); 349 391 350 Result := Utils.Generate_Relationship (Tree, Utils.From_Child); 392 Utils.Check (Tree, Utils.Ascending); 393 declare 394 Relation : Relationship := Utils.Generate_Relationship 395 (Tree, null, 0, Utils.Ascending); 396 begin 397 Clear; 398 return Relation; 399 end; 351 400 352 401 when Descendants => 353 402 Tree := Get_Descendants 403 (Normalized_Compilation_Units (1 .. Compilation_Units_Last), The_Context); 404 405 Utils.Check (Tree, Utils.Ascending); 406 declare 407 Relation : Relationship := Utils.Generate_Relationship 408 (Tree, Normalized_Dependent_Units, Dependent_Units_Last, Utils.Descending); 409 begin 410 Clear; 411 return Relation; 412 end; 413 414 when Supporters => 415 Tree := Get_Supporters 354 416 (Normalized_Compilation_Units (1 .. Compilation_Units_Last), 355 417 The_Context); 356 418 357 Result := Utils.Generate_Relationship (Tree, Utils.From_Parent);358 359 when Supporters =>360 419 Asis.Implementation.Set_Status 361 420 (Not_Implemented_Error, … … 384 443 end case; 385 444 386 Deallocate (Tree); 387 Utils.Deallocate (Normalized_Compilation_Units); 388 Utils.Deallocate (Normalized_Dependent_Units); 389 390 return Result; 445 Clear; 446 return Nil_Relationship; 391 447 392 448 exception 393 449 when others => 394 Deallocate (Tree); 395 Utils.Deallocate (Normalized_Compilation_Units); 396 Utils.Deallocate (Normalized_Dependent_Units); 397 450 Clear; 398 451 raise; 399 452 end Semantic_Dependence_Order; … … 414 467 415 468 Result : Tree_Node_Access := null; 416 Tmp_Tree : Tree_Node_Access := n ew Tree_Node;469 Tmp_Tree : Tree_Node_Access := null; 417 470 Node : Tree_Node_Access := null; 418 471 … … 431 484 if Node /= null then 432 485 Add_Thread (Result, Node, Tmp_Tree); 433 Tmp_Tree := new Tree_Node;434 486 return True; 435 487 else … … 442 494 procedure Retrive_Declarations is 443 495 begin 444 Kinds := Unit_Kind (Unit); 445 446 while Kinds in A_Procedure .. A_Generic_Package_Renaming loop 496 while Unit_Kind (Unit) in A_Procedure .. A_Generic_Package_Renaming loop 447 497 if Append_Node (Unit) then 448 498 return; 449 499 end if; 450 500 451 Unit := Corresponding_Parent_Declaration (Unit); 452 Kinds := Unit_Kind (Unit); 501 Unit := Corresponding_Parent_Declaration (Unit); 453 502 end loop; 454 503 … … 460 509 -- add Standart as root 461 510 if Append_Node 462 ( Compilation_Unit_Body("Standard", The_Context))511 (Library_Unit_Declaration ("Standard", The_Context)) 463 512 then 464 513 return; … … 468 517 469 518 -- Retrive_Subunit -- 470 procedure Retrive_Subunit is 471 begin 472 -- RM 10.1.3 (8/2) 473 if Append_Node (Unit) then 474 return; 475 end if; 476 477 loop 478 Unit := Corresponding_Subunit_Parent_Body (Unit); 479 exit when Unit_Kind (Unit) not in A_Subunit; 480 if Append_Node (Unit) then 481 return; 482 end if; 483 end loop; 484 485 if Append_Node (Unit) then 486 return; 487 end if; 488 489 if Unit_Kind (Unit) /= A_Nonexistent_Body then 490 Unit := Corresponding_Parent_Declaration (Unit, The_Context); 491 Retrive_Declarations; 492 else 519 -- procedure Retrive_Subunit is 520 -- begin 521 -- if Append_Node (Unit) then 522 -- return; 523 -- end if; 524 525 -- loop 526 -- Unit := Corresponding_Subunit_Parent_Body (Unit); 527 528 -- if Append_Node (Unit) then 529 -- return; 530 -- end if; 531 532 -- exit when Unit_Kind (Unit) not in A_Subunit; 533 -- end loop; 534 535 -- if Unit_Kind (Unit) /= A_Nonexistent_Body then 536 -- Unit := Corresponding_Parent_Declaration (Unit, The_Context); 537 -- Retrive_Declarations; 538 -- else 493 539 -- add Standart as root 494 if Append_Node495 (Compilation_Unit_Body("Standard", The_Context))496 then497 return;498 end if;499 end if;500 end Retrive_Subunit;540 -- if Append_Node 541 -- (Library_Unit_Declaration ("Standard", The_Context)) 542 -- then 543 -- return; 544 -- end if; 545 -- end if; 546 -- end Retrive_Subunit; 501 547 502 548 begin 503 549 for Index in List'Range loop 504 Clear (Tmp_Tree.all); 550 if Tmp_Tree /= null then 551 Asis.Implementation.Set_Status 552 (Asis.Errors.Internal_Error, 553 "Bug (or inapropriate use) detected in " 554 & "Asis.Compilation_Units.Relations.Semantic_Dependence_Order(Ancestors)"); 555 556 raise Asis.Exceptions.ASIS_Failed; 557 end if; 558 559 Tmp_Tree := new Tree_Node; 560 505 561 Unit := List (Index); 506 562 Kinds := Unit_Kind (Unit); 507 563 508 564 if Kinds in A_Subunit then 509 Retrive_Subunit; 565 -- Retrive_Subunit; 566 null; 510 567 511 568 elsif Kinds in A_Library_Unit_Body then … … 518 575 519 576 if Result = null then 520 Result := Tmp_Tree; 577 Result := Tmp_Tree; 578 Tmp_Tree := null; 521 579 end if; 522 580 end loop; … … 542 600 use Utils; 543 601 544 Result : Tree_Node_Access := new Tree_Node; 545 Unit : Compilation_Unit; 546 Kinds : Unit_Kinds; 602 Result : Tree_Node_Access := new Tree_Node; 603 Unit : Compilation_Unit; 604 Second_Unit : Compilation_Unit; 605 Kinds : Unit_Kinds; 547 606 548 607 -- Retrive -- … … 553 612 Children_List : Asis.Compilation_Unit_List := 554 613 Corresponding_Children (Target, The_Context); 555 Exist_Node : Utils.Tree_Node_Access; 556 557 Second_Unit : Compilation_Unit; 614 Exist_Node : Utils.Tree_Node_Access := null; 615 616 -- Process -- 617 function Process 618 (Index : in List_Index) 619 return Boolean 620 is 621 begin 622 if Is_Nil (Unit) then 623 return False; 624 end if; 625 626 Exist_Node := Find (Result.all, Unit); 627 628 if Exist_Node /= null then 629 Glue_Nodes (Result, Node, Exist_Node); 630 return False; 631 end if; 632 633 Kinds := Unit_Kind (Unit); 634 635 if Kinds in 636 A_Procedure_Instance .. A_Generic_Package_Renaming 637 then 638 Exist_Node := Add_Child (Result, Node, Unit, null); 639 640 elsif Kinds in A_Procedure .. A_Generic_Package then 641 Second_Unit := Corresponding_Body (Unit, The_Context); 642 643 if not Is_Identical (Second_Unit, Nil_Compilation_Unit) 644 and then not Is_Identical (Second_Unit, Unit) 645 then 646 Exist_Node := Add_Child (Result, Node, Unit, Second_Unit); 647 Remove_From_List (Children_List, Index + 1, Second_Unit); 648 else 649 Exist_Node := Add_Child (Result, Node, Unit, null); 650 end if; 651 652 elsif Kinds in A_Library_Unit_Body then 653 Second_Unit := Corresponding_Declaration (Unit, The_Context); 654 655 if not Is_Identical (Second_Unit, Nil_Compilation_Unit) 656 and then not Is_Identical (Second_Unit, Unit) 657 then 658 Exist_Node := Add_Child (Result, Node, Second_Unit, Unit); 659 Remove_From_List (Children_List, Index + 1, Second_Unit); 660 Unit := Second_Unit; 661 else 662 Exist_Node := Add_Child (Result, Node, Unit, null); 663 end if; 664 665 else 666 Exist_Node := Add_Child (Result, Node, Unit, null); 667 end if; 668 669 return True; 670 end Process; 671 558 672 begin 559 673 for Index in Children_List'Range loop 560 674 Unit := Children_List (Index); 561 675 562 if not Is_Nil (Unit) then 563 Exist_Node := null; 564 565 if Node /= null then 566 Exist_Node := Close_Find (Node.all, Unit); 567 end if; 568 569 if Exist_Node = null then 570 Exist_Node := Find (Result.all, Unit); 571 572 if Exist_Node = null then 573 Kinds := Unit_Kind (Unit); 574 575 if Kinds in 576 A_Procedure_Instance .. A_Generic_Package_Renaming 577 then 578 Exist_Node := Add_Child (Result, Node, Unit, null); 579 580 elsif Kinds in A_Procedure .. A_Generic_Package then 581 Second_Unit := Corresponding_Body (Unit, The_Context); 582 583 Exist_Node := Add_Child 584 (Result, Node, Unit, Second_Unit); 585 586 Remove_From_List 587 (Children_List, Index + 1, Second_Unit); 588 589 elsif Kinds in A_Library_Unit_Body then 590 Second_Unit := Corresponding_Declaration 591 (Unit, The_Context); 592 593 Exist_Node := Add_Child 594 (Result, Node, Second_Unit, Unit); 595 596 Remove_From_List 597 (Children_List, Index + 1, Second_Unit); 598 else 599 Exist_Node := Add_Child 600 (Result, Node, Unit, null); 601 end if; 602 603 if Kinds = A_Package 604 or else Kinds = A_Generic_Package 605 or else Kinds = A_Package_Instance 606 then 607 Retrive (Unit, Exist_Node); 608 end if; 609 else 610 Glue_Nodes (Result, Node, Exist_Node); 611 end if; 676 if Process (Index) then 677 Kinds := Unit_Kind (Unit); 678 679 if Kinds = A_Package 680 or else Kinds = A_Generic_Package 681 or else Kinds = A_Package_Instance 682 then 683 Retrive (Unit, Exist_Node); 612 684 end if; 613 685 end if; … … 649 721 650 722 for Index in 1 .. Declarations_Last loop 651 Retrive (Declarations_List (Index), null); 723 Unit := Declarations_List (Index); 724 725 if Find (Result.all, Unit) = null then 726 Second_Unit := Corresponding_Body (Unit, The_Context); 727 728 if not Is_Identical (Second_Unit, Nil_Compilation_Unit) 729 and then not Is_Identical (Second_Unit, Unit) 730 then 731 Retrive (Unit, Add_Child (Result, null, Unit, Second_Unit)); 732 else 733 Retrive (Unit, Add_Child (Result, null, Unit, null)); 734 end if; 735 end if; 652 736 end loop; 653 737 … … 662 746 end Get_Descendants; 663 747 748 -------------------- 749 -- Get_Supporters -- 750 -------------------- 751 752 function Get_Supporters 753 (List : in Asis.Compilation_Unit_List; 754 The_Context : in Asis.Context) 755 return Utils.Tree_Node_Access 756 is 757 use Utils; 758 759 -- Unit : Compilation_Unit; 760 -- Kinds : Unit_Kinds; 761 762 Result : Tree_Node_Access := new Tree_Node; 763 -- Node : Tree_Node_Access := null; 764 765 -- Append_Standart -- 766 -- procedure Append_Standart 767 -- (Node : in Tree_Node_Access) 768 -- is 769 -- Std : Compilation_Unit := Library_Unit_Declaration 770 -- ("Standard", The_Context); 771 772 -- Exist_Node : Tree_Node_Access; 773 -- begin 774 -- Exist_Node := Find (Result.all, Std); 775 776 -- if Exist_Node = null then 777 -- Exist_Node := Add_Child (Result, Node, Unit); 778 -- else 779 -- if Node /= null then 780 -- Glue_Nodes (Result, Node, Exist_Node); 781 -- end if; 782 -- end if; 783 -- end Append_Standart; 784 785 -- Reorder -- 786 -- procedure Reorder 787 -- (Unit : in Compilation_Unit; 788 -- Node : in Tree_Node_Access) 789 -- is 790 -- begin 791 -- Kinds := Unit_Kind (Unit); 792 793 -- if Is_Nill (Unit) 794 -- or else Kinds in A_Nonexistent_Declaration .. An_Unknown_Unit 795 -- then 796 -- Append_Standart (Node); 797 798 -- elsif Kinds in A_Subunit then 799 -- Retrive_Subunit (Unit, Node); 800 801 -- elsif Kinds = A_Package_Body then 802 -- Retrive_Body (Unit, Node); 803 804 -- elsif Kinds in A_Subprogram_Body then 805 -- Retrive_Subprogram_Body (Get_Package_Body (Unit), Node); 806 807 -- else 808 -- Retrive_Declarations (Unit, Node); 809 -- end if; 810 -- end Reorder; 811 812 -- Retrive_Subunit -- 813 -- procedure Retrive_Subunit 814 -- (Unit : in Compilation_Unit; 815 -- Node : in Tree_Node_Access) 816 -- is 817 -- Parent : Compilation_Unit; 818 -- Exist_Node : Tree_Node_Access := Node; 819 -- begin 820 -- Parent := Corresponding_Subunit_Parent_Body (Unit); 821 822 -- while Unit_Kind (Parent) in A_Subunit loop 823 -- Exist_Node := Find (Result.all, Parent); 824 825 -- if Exist_Node = null then 826 -- Exist_Node := Add_Child (Result, Node, Unit); 827 -- else 828 -- if Node /= null then 829 -- Glue_Nodes (Result, Node, Exist_Node); 830 -- return; 831 -- end if; 832 -- end if; 833 834 -- Parent := Corresponding_Subunit_Parent_Body (Unit); 835 -- end loop; 836 837 -- Reorder (Parent, Exist_Node); 838 -- end Retrive_Subunit; 839 840 begin 841 -- for Index in List'Range loop 842 -- Unit := List (Index); 843 -- Reorder (List (Index), null); 844 -- end loop; 845 846 return Result; 847 exception 848 when others => 849 Deallocate (Result); 850 raise; 851 end Get_Supporters; 852 664 853 ------------ 665 854 -- Utils -- … … 703 892 end if; 704 893 705 if This.Prev /= null then 706 raise Use_Error; 707 end if; 708 709 Node := Find (This.all, Unit); 710 711 if Node /= null then 712 -- circular 894 if This.Prev /= null 895 or else Find (This.all, Unit) /= null 896 then 713 897 raise Use_Error; 714 898 end if; … … 791 975 New_Node : Tree_Node_Access := new Tree_Node; 792 976 begin 793 if This.Prev /= null 794 then 977 if This.Prev /= null then 795 978 -- not root 796 979 raise Use_Error; … … 822 1005 is 823 1006 begin 824 if This.Prev /= null 825 then 1007 if This.Prev /= null then 826 1008 -- not root 827 1009 raise Use_Error; … … 858 1040 Deallocate (This.Circular); 859 1041 Deallocate (This.Missing); 1042 Deallocate (This.Inconsistent); 860 1043 end Clear; 1044 1045 ----------- 1046 -- Check -- 1047 ----------- 1048 1049 procedure Check 1050 (This : in Tree_Node_Access; 1051 Order : in Orders) 1052 is 1053 Node : Tree_Node_Access := This; 1054 Kinds, Parent_Kinds : Unit_Kinds; 1055 Perent_Unit : Compilation_Unit; 1056 begin 1057 if Order = Ascending then 1058 if not Is_Nil (Node.Unit) then 1059 Kinds := Unit_Kind (Node.Unit); 1060 1061 -- inconsistent 1062 if Node.Consistent then 1063 if not Is_Inconsistent (Node.Unit) then 1064 Node.Consistent := False; 1065 1066 if Is_Source_Changed (Node.Unit) then 1067 Node.Inconsistent := Append 1068 (Node.Inconsistent, 1069 (Nil_Compilation_Unit, Node.Unit)); 1070 else 1071 if not Is_Nil (Node.Prev.Unit) then 1072 Node.Inconsistent := Append 1073 (Node.Inconsistent, 1074 (Node.Prev.Unit, Node.Unit)); 1075 else 1076 Node.Inconsistent := Append 1077 (Node.Inconsistent, 1078 (Node.Unit, Node.Unit)); 1079 end if; 1080 end if; 1081 end if; 1082 1083 if not Is_Nil (Node.Unit_Body) then 1084 if not Node.Consistent then 1085 Node.Inconsistent := Append 1086 (Node.Inconsistent, 1087 (Node.Unit, Node.Unit_Body)); 1088 else 1089 if not Is_Inconsistent (Node.Unit_Body) then 1090 if Is_Source_Changed (Node.Unit_Body) then 1091 Node.Inconsistent := Append 1092 (Node.Inconsistent, 1093 (Nil_Compilation_Unit, Node.Unit_Body)); 1094 else 1095 Node.Inconsistent := Append 1096 (Node.Inconsistent, 1097 (Node.Unit_Body, Node.Unit_Body)); 1098 end if; 1099 end if; 1100 end if; 1101 end if; 1102 1103 if not Node.Consistent 1104 and then Node.Next /= null 1105 then 1106 for Index in Node.Next.all'Range loop 1107 Node.Inconsistent := Set_Inconsistent 1108 (Node.Next.all (Index), Node.Inconsistent, Order); 1109 end loop; 1110 end if; 1111 end if; 1112 1113 if Node.Prev /= null 1114 and then not Is_Nil (Node.Prev.Unit) 1115 then 1116 Perent_Unit := Node.Prev.Unit; 1117 Parent_Kinds := Unit_Kind (Perent_Unit); 1118 1119 -- missing 1120 if Kinds in A_Procedure .. A_Generic_Package_Renaming then 1121 if Parent_Kinds = A_Nonexistent_Declaration then 1122 Node.Missing := Append 1123 (Node.Missing, (Node.Unit, Perent_Unit)); 1124 end if; 1125 1126 elsif Kinds in A_Library_Unit_Body then 1127 if Parent_Kinds = A_Nonexistent_Body then 1128 Node.Missing := Append 1129 (Node.Missing, (Node.Unit, Perent_Unit)); 1130 end if; 1131 end if; 1132 1133 if not Is_Nil (Node.Unit_Body) then 1134 if not Is_Nil (Node.Prev.Unit_Body) then 1135 Perent_Unit := Node.Prev.Unit_Body; 1136 end if; 1137 1138 Parent_Kinds := Unit_Kind (Perent_Unit); 1139 1140 if Kinds = A_Nonexistent_Declaration 1141 or else Kinds = A_Nonexistent_Declaration 1142 then 1143 Node.Missing := Append 1144 (Node.Missing, (Node.Unit_Body, Node.Unit)); 1145 end if; 1146 1147 if Parent_Kinds = A_Nonexistent_Body then 1148 Node.Missing := Append 1149 (Node.Missing, (Node.Unit_Body, Perent_Unit)); 1150 end if; 1151 end if; 1152 end if; 1153 end if; 1154 1155 if Node.Next /= null then 1156 for Index in Node.Next.all'Range loop 1157 Check (Node.Next.all (Index), Order); 1158 end loop; 1159 end if; 1160 else 1161 null; 1162 end if; 1163 end Check; 861 1164 862 1165 --------------------------- … … 865 1168 866 1169 function Generate_Relationship 867 (This : in Tree_Node_Access; 868 Order : in Orders) 1170 (This : in Tree_Node_Access; 1171 Limit_List : in Utils.Compilation_Unit_List_Access; 1172 List_Last : in ASIS_Integer; 1173 Order : in Orders) 869 1174 return Relationship 870 1175 is 871 1176 Consistent_List : Compilation_Unit_List_Access := null; 1177 Inconsistent_List : Compilation_Unit_List_Access := null; 872 1178 Missing_List : Compilation_Unit_List_Access := null; 873 1179 Circular_List : Compilation_Unit_List_Access := null; 874 1180 875 1181 Consistent_Length : Asis.ASIS_Natural := 0; 1182 Inconsistent_Length : Asis.ASIS_Natural := 0; 876 1183 Missing_Length : Asis.ASIS_Natural := 0; 877 1184 Circular_Length : Asis.ASIS_Natural := 0; 878 1185 1186 -- Genegate_Inconsistent -- 1187 procedure Genegate_Inconsistent 1188 (Node : in Tree_Node_Access) 1189 is 1190 begin 1191 if Node.Inconsistent /= null 1192 and then not Node.Inconsistent_Added 1193 then 1194 Node.Inconsistent_Added := True; 1195 1196 Inconsistent_List := Append 1197 (Inconsistent_List, Node.Inconsistent.all); 1198 end if; 1199 end Genegate_Inconsistent; 1200 879 1201 -- Genegate_Circular -- 880 1202 procedure Genegate_Circular 881 ( List : Compilation_Unit_List_Access)1203 (Node : in Tree_Node_Access) 882 1204 is 883 1205 begin 884 for Index in List.all'Range loop 885 Circular_List := Append (Circular_List, List.all (Index)); 886 887 if Index < List.all'Last then 1206 if Node.Circular /= null 1207 and then not Node.Circular_Added 1208 then 1209 Node.Circular_Added := True; 1210 1211 for Index in Node.Circular.all'Range loop 888 1212 Circular_List := Append 889 (Circular_List, List.all (Index + 1)); 890 else 891 Circular_List := Append (Circular_List, List.all (1)); 892 end if; 893 end loop; 1213 (Circular_List, Node.Circular.all (Index)); 1214 1215 if Index < Node.Circular.all'Last then 1216 Circular_List := Append 1217 (Circular_List, Node.Circular.all (Index + 1)); 1218 else 1219 Circular_List := Append 1220 (Circular_List, Node.Circular.all (1)); 1221 end if; 1222 end loop; 1223 end if; 894 1224 end Genegate_Circular; 1225 1226 -- Genegate_Missing -- 1227 procedure Genegate_Missing 1228 (Node : in Tree_Node_Access) 1229 is 1230 begin 1231 if Node.Missing /= null 1232 and then not Node.Missing_Added 1233 then 1234 Node.Missing_Added := True; 1235 1236 Missing_List := Append (Missing_List, Node.Missing.all); 1237 end if; 1238 end Genegate_Missing; 895 1239 896 1240 -- Process_Asc -- … … 899 1243 is 900 1244 Internal_Node : Tree_Node_Access := Node; 901 Prev_Node : Tree_Node_Access;902 903 1245 begin 904 1246 while Internal_Node /= null loop … … 910 1252 Internal_Node.Added := True; 911 1253 912 Consistent_List := Append 913 (Consistent_List, Internal_Node.Unit); 914 915 if Internal_Node.Missing /= null 916 and then not Internal_Node.Missing_Added 917 then 918 Missing_List := Append (Missing_List, Internal_Node.Missing.all); 919 Internal_Node.Missing_Added := True; 1254 if Internal_Node.Consistent then 1255 Consistent_List := Append 1256 (Consistent_List, Internal_Node.Unit); 920 1257 end if; 921 1258 922 if Internal_Node.Circular /= null 923 and then not Internal_Node.Circular_Added 924 then 925 Genegate_Circular (Internal_Node.Circular); 926 Internal_Node.Circular_Added := True; 927 end if; 928 929 Prev_Node := Internal_Node; 1259 Genegate_Inconsistent (Internal_Node); 1260 Genegate_Missing (Internal_Node); 1261 Genegate_Circular (Internal_Node); 930 1262 end if; 931 1263 … … 936 1268 -- Process_Dsc -- 937 1269 procedure Process_Dsc 938 ( Target: in Tree_Node_Access)1270 (Node : in Tree_Node_Access) 939 1271 is 1272 -- Add_To_Consistent -- 1273 procedure Add_To_Consistent 1274 (Unit : in Compilation_Unit) 1275 is 1276 begin 1277 if Limit_List /= null then 1278 if In_List (Limit_List, List_Last, Unit) then 1279 Consistent_List := Append (Consistent_List, Unit); 1280 end if; 1281 else 1282 Consistent_List := Append (Consistent_List, Unit); 1283 end if; 1284 end Add_To_Consistent; 940 1285 begin 941 if Target.Added then1286 if Node.Added then 942 1287 return; 943 1288 end if; 944 1289 945 Target.Added := True; 946 947 Consistent_List := Append (Consistent_List, Target.Unit); 948 949 if not Is_Nil (Target.Unit_Body) then 950 Consistent_List := Append (Consistent_List, Target.Unit); 951 end if; 952 953 if Target.Missing /= null 954 and then not Target.Missing_Added 955 then 956 Missing_List := Append (Missing_List, Target.Missing.all); 957 Target.Missing_Added := True; 958 end if; 959 960 if Target.Circular /= null 961 and then not Target.Circular_Added 962 then 963 Genegate_Circular (Target.Circular); 964 Target.Circular_Added := True; 965 end if; 966 967 if Target.Next /= null then 968 for Index in Target.Next.all'Range loop 969 Process_Dsc (Target.Next.all (Index)); 1290 Node.Added := True; 1291 1292 if Node.Consistent then 1293 Add_To_Consistent (Node.Unit); 1294 1295 if not Is_Nil (Node.Unit_Body) 1296 and then Is_Inconsistent (Node.Unit_Body) 1297 then 1298 Add_To_Consistent (Node.Unit_Body); 1299 end if; 1300 end if; 1301 1302 Genegate_Inconsistent (Node); 1303 Genegate_Missing (Node); 1304 Genegate_Circular (Node); 1305 1306 if Node.Next /= null then 1307 for Index in Node.Next.all'Range loop 1308 Process_Dsc (Node.Next.all (Index)); 970 1309 end loop; 971 1310 end if; … … 973 1312 974 1313 begin 975 if Order = From_Childthen1314 if Order = Ascending then 976 1315 if Is_Empty (This.all) then 977 1316 return Nil_Relationship; … … 1003 1342 end if; 1004 1343 1344 if Inconsistent_List /= null then 1345 Inconsistent_Length := Inconsistent_List.all'Length; 1346 end if; 1347 1005 1348 if Missing_List /= null then 1006 1349 Missing_Length := Missing_List.all'Length; … … 1013 1356 declare 1014 1357 Result : Relationship 1015 (Consistent_Length, 0, Missing_Length, Circular_Length); 1358 (Consistent_Length, Inconsistent_Length, 1359 Missing_Length, Circular_Length);