Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/ghost.adb @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
4 -- -- 4 -- --
5 -- G H O S T -- 5 -- G H O S T --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- 9 -- Copyright (C) 2014-2018, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under -- 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- -- 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- -- 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- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
27 with Aspects; use Aspects; 27 with Aspects; use Aspects;
28 with Atree; use Atree; 28 with Atree; use Atree;
29 with Einfo; use Einfo; 29 with Einfo; use Einfo;
30 with Elists; use Elists; 30 with Elists; use Elists;
31 with Errout; use Errout; 31 with Errout; use Errout;
32 with Lib; use Lib;
33 with Namet; use Namet; 32 with Namet; use Namet;
34 with Nlists; use Nlists; 33 with Nlists; use Nlists;
35 with Nmake; use Nmake; 34 with Nmake; use Nmake;
36 with Sem; use Sem; 35 with Sem; use Sem;
37 with Sem_Aux; use Sem_Aux; 36 with Sem_Aux; use Sem_Aux;
44 with Snames; use Snames; 43 with Snames; use Snames;
45 with Table; 44 with Table;
46 45
47 package body Ghost is 46 package body Ghost is
48 47
49 -- The following table contains the N_Compilation_Unit node for a unit that 48 ---------------------
50 -- is either subject to pragma Ghost with policy Ignore or contains ignored 49 -- Data strictures --
51 -- Ghost code. The table is used in the removal of ignored Ghost code from 50 ---------------------
52 -- units. 51
53 52 -- The following table contains all ignored Ghost nodes that must be
54 package Ignored_Ghost_Units is new Table.Table ( 53 -- eliminated from the tree by routine Remove_Ignored_Ghost_Code.
54
55 package Ignored_Ghost_Nodes is new Table.Table (
55 Table_Component_Type => Node_Id, 56 Table_Component_Type => Node_Id,
56 Table_Index_Type => Int, 57 Table_Index_Type => Int,
57 Table_Low_Bound => 0, 58 Table_Low_Bound => 0,
58 Table_Initial => Alloc.Ignored_Ghost_Units_Initial, 59 Table_Initial => Alloc.Ignored_Ghost_Nodes_Initial,
59 Table_Increment => Alloc.Ignored_Ghost_Units_Increment, 60 Table_Increment => Alloc.Ignored_Ghost_Nodes_Increment,
60 Table_Name => "Ignored_Ghost_Units"); 61 Table_Name => "Ignored_Ghost_Nodes");
61 62
62 ----------------------- 63 -----------------------
63 -- Local Subprograms -- 64 -- Local subprograms --
64 ----------------------- 65 -----------------------
65 66
66 function Ghost_Entity (N : Node_Id) return Entity_Id; 67 function Ghost_Entity (N : Node_Id) return Entity_Id;
67 -- Find the entity of a reference to a Ghost entity. Return Empty if there 68 -- Find the entity of a reference to a Ghost entity. Return Empty if there
68 -- is no such entity. 69 -- is no such entity.
69 70
70 procedure Install_Ghost_Mode (Mode : Name_Id); 71 procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type);
71 -- Install a specific Ghost mode denoted by Mode by setting global variable 72 pragma Inline (Install_Ghost_Mode);
72 -- Ghost_Mode. 73 -- Install Ghost mode Mode as the Ghost mode in effect
74
75 procedure Install_Ghost_Region (Mode : Name_Id; N : Node_Id);
76 pragma Inline (Install_Ghost_Region);
77 -- Install a Ghost region comprised of mode Mode and ignored region start
78 -- node N.
73 79
74 function Is_Subject_To_Ghost (N : Node_Id) return Boolean; 80 function Is_Subject_To_Ghost (N : Node_Id) return Boolean;
75 -- Determine whether declaration or body N is subject to aspect or pragma 81 -- Determine whether declaration or body N is subject to aspect or pragma
76 -- Ghost. This routine must be used in cases where pragma Ghost has not 82 -- Ghost. This routine must be used in cases where pragma Ghost has not
77 -- been analyzed yet, but the context needs to establish the "ghostness" 83 -- been analyzed yet, but the context needs to establish the "ghostness"
82 Mode : Name_Id); 88 Mode : Name_Id);
83 -- Mark the defining entity of declaration or body N as Ghost depending on 89 -- Mark the defining entity of declaration or body N as Ghost depending on
84 -- mode Mode. Mark all formals parameters when N denotes a subprogram or a 90 -- mode Mode. Mark all formals parameters when N denotes a subprogram or a
85 -- body. 91 -- body.
86 92
87 procedure Propagate_Ignored_Ghost_Code (N : Node_Id); 93 function Name_To_Ghost_Mode (Mode : Name_Id) return Ghost_Mode_Type;
88 -- Signal all enclosing scopes that they now contain at least one ignored 94 pragma Inline (Name_To_Ghost_Mode);
89 -- Ghost node denoted by N. Add the compilation unit containing N to table 95 -- Convert a Ghost mode denoted by name Mode into its respective enumerated
90 -- Ignored_Ghost_Units for post processing. 96 -- value.
91 97
92 ---------------------------- 98 procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id);
93 -- Add_Ignored_Ghost_Unit -- 99 -- Save ignored Ghost node or entity N in table Ignored_Ghost_Nodes for
94 ---------------------------- 100 -- later elimination.
95
96 procedure Add_Ignored_Ghost_Unit (Unit : Node_Id) is
97 begin
98 pragma Assert (Nkind (Unit) = N_Compilation_Unit);
99
100 -- Avoid duplicates in the table as pruning the same unit more than once
101 -- is wasteful. Since ignored Ghost code tends to be grouped up, check
102 -- the contents of the table in reverse.
103
104 for Index in reverse Ignored_Ghost_Units.First ..
105 Ignored_Ghost_Units.Last
106 loop
107 -- If the unit is already present in the table, do not add it again
108
109 if Unit = Ignored_Ghost_Units.Table (Index) then
110 return;
111 end if;
112 end loop;
113
114 -- If we get here, then this is the first time the unit is being added
115
116 Ignored_Ghost_Units.Append (Unit);
117 end Add_Ignored_Ghost_Unit;
118 101
119 ---------------------------- 102 ----------------------------
120 -- Check_Ghost_Completion -- 103 -- Check_Ghost_Completion --
121 ---------------------------- 104 ----------------------------
122 105
804 Constit, State_Id); 787 Constit, State_Id);
805 end if; 788 end if;
806 end if; 789 end if;
807 end Check_Ghost_Refinement; 790 end Check_Ghost_Refinement;
808 791
792 ----------------------
793 -- Check_Ghost_Type --
794 ----------------------
795
796 procedure Check_Ghost_Type (Typ : Entity_Id) is
797 Conc_Typ : Entity_Id;
798 Full_Typ : Entity_Id;
799
800 begin
801 if Is_Ghost_Entity (Typ) then
802 Conc_Typ := Empty;
803 Full_Typ := Typ;
804
805 if Is_Single_Concurrent_Type (Typ) then
806 Conc_Typ := Anonymous_Object (Typ);
807 Full_Typ := Conc_Typ;
808
809 elsif Is_Concurrent_Type (Typ) then
810 Conc_Typ := Typ;
811 end if;
812
813 -- A Ghost type cannot be concurrent (SPARK RM 6.9(19)). Verify this
814 -- legality rule first to give a finer-grained diagnostic.
815
816 if Present (Conc_Typ) then
817 Error_Msg_N ("ghost type & cannot be concurrent", Conc_Typ);
818 end if;
819
820 -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(7))
821
822 if Is_Effectively_Volatile (Full_Typ) then
823 Error_Msg_N ("ghost type & cannot be volatile", Full_Typ);
824 end if;
825 end if;
826 end Check_Ghost_Type;
827
809 ------------------ 828 ------------------
810 -- Ghost_Entity -- 829 -- Ghost_Entity --
811 ------------------ 830 ------------------
812 831
813 function Ghost_Entity (N : Node_Id) return Entity_Id is 832 function Ghost_Entity (N : Node_Id) return Entity_Id is
861 -- Initialize -- 880 -- Initialize --
862 ---------------- 881 ----------------
863 882
864 procedure Initialize is 883 procedure Initialize is
865 begin 884 begin
866 Ignored_Ghost_Units.Init; 885 Ignored_Ghost_Nodes.Init;
886
887 -- Set the soft link which enables Atree.Mark_New_Ghost_Node to record
888 -- an ignored Ghost node or entity.
889
890 Set_Ignored_Ghost_Recording_Proc (Record_Ignored_Ghost_Node'Access);
867 end Initialize; 891 end Initialize;
868 892
869 ------------------------ 893 ------------------------
870 -- Install_Ghost_Mode -- 894 -- Install_Ghost_Mode --
871 ------------------------ 895 ------------------------
872 896
873 procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type) is 897 procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type) is
874 begin 898 begin
899 Install_Ghost_Region (Mode, Empty);
900 end Install_Ghost_Mode;
901
902 --------------------------
903 -- Install_Ghost_Region --
904 --------------------------
905
906 procedure Install_Ghost_Region (Mode : Ghost_Mode_Type; N : Node_Id) is
907 begin
908 -- The context is already within an ignored Ghost region. Maintain the
909 -- start of the outermost ignored Ghost region.
910
911 if Present (Ignored_Ghost_Region) then
912 null;
913
914 -- The current region is the outermost ignored Ghost region. Save its
915 -- starting node.
916
917 elsif Present (N) and then Mode = Ignore then
918 Ignored_Ghost_Region := N;
919
920 -- Otherwise the current region is not ignored, nothing to save
921
922 else
923 Ignored_Ghost_Region := Empty;
924 end if;
925
875 Ghost_Mode := Mode; 926 Ghost_Mode := Mode;
876 end Install_Ghost_Mode; 927 end Install_Ghost_Region;
877 928
878 procedure Install_Ghost_Mode (Mode : Name_Id) is 929 procedure Install_Ghost_Region (Mode : Name_Id; N : Node_Id) is
879 begin 930 begin
880 if Mode = Name_Check then 931 Install_Ghost_Region (Name_To_Ghost_Mode (Mode), N);
881 Ghost_Mode := Check; 932 end Install_Ghost_Region;
882
883 elsif Mode = Name_Ignore then
884 Ghost_Mode := Ignore;
885
886 elsif Mode = Name_None then
887 Ghost_Mode := None;
888 end if;
889 end Install_Ghost_Mode;
890 933
891 ------------------------- 934 -------------------------
892 -- Is_Ghost_Assignment -- 935 -- Is_Ghost_Assignment --
893 ------------------------- 936 -------------------------
894 937
959 --------------------------- 1002 ---------------------------
960 -- Is_Ignored_Ghost_Unit -- 1003 -- Is_Ignored_Ghost_Unit --
961 --------------------------- 1004 ---------------------------
962 1005
963 function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is 1006 function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is
1007 function Ultimate_Original_Node (Nod : Node_Id) return Node_Id;
1008 -- Obtain the original node of arbitrary node Nod following a potential
1009 -- chain of rewritings.
1010
1011 ----------------------------
1012 -- Ultimate_Original_Node --
1013 ----------------------------
1014
1015 function Ultimate_Original_Node (Nod : Node_Id) return Node_Id is
1016 Res : Node_Id;
1017
1018 begin
1019 Res := Nod;
1020 while Original_Node (Res) /= Res loop
1021 Res := Original_Node (Res);
1022 end loop;
1023
1024 return Res;
1025 end Ultimate_Original_Node;
1026
1027 -- Start of processing for Is_Ignored_Ghost_Unit
1028
964 begin 1029 begin
965 -- Inspect the original node of the unit in case removal of ignored 1030 -- Inspect the original node of the unit in case removal of ignored
966 -- Ghost code has already taken place. 1031 -- Ghost code has already taken place.
967 1032
968 return 1033 return
969 Nkind (N) = N_Compilation_Unit 1034 Nkind (N) = N_Compilation_Unit
970 and then Is_Ignored_Ghost_Entity 1035 and then Is_Ignored_Ghost_Entity
971 (Defining_Entity (Original_Node (Unit (N)))); 1036 (Defining_Entity (Ultimate_Original_Node (Unit (N))));
972 end Is_Ignored_Ghost_Unit; 1037 end Is_Ignored_Ghost_Unit;
973 1038
974 ------------------------- 1039 -------------------------
975 -- Is_Subject_To_Ghost -- 1040 -- Is_Subject_To_Ghost --
976 ------------------------- 1041 -------------------------
1105 -- Lock -- 1170 -- Lock --
1106 ---------- 1171 ----------
1107 1172
1108 procedure Lock is 1173 procedure Lock is
1109 begin 1174 begin
1110 Ignored_Ghost_Units.Release; 1175 Ignored_Ghost_Nodes.Release;
1111 Ignored_Ghost_Units.Locked := True; 1176 Ignored_Ghost_Nodes.Locked := True;
1112 end Lock; 1177 end Lock;
1113 1178
1114 ----------------------------------- 1179 -----------------------------------
1115 -- Mark_And_Set_Ghost_Assignment -- 1180 -- Mark_And_Set_Ghost_Assignment --
1116 ----------------------------------- 1181 -----------------------------------
1124 1189
1125 Id := Ghost_Entity (Name (N)); 1190 Id := Ghost_Entity (Name (N));
1126 1191
1127 if Present (Id) then 1192 if Present (Id) then
1128 if Is_Checked_Ghost_Entity (Id) then 1193 if Is_Checked_Ghost_Entity (Id) then
1129 Install_Ghost_Mode (Check); 1194 Install_Ghost_Region (Check, N);
1130 1195
1131 elsif Is_Ignored_Ghost_Entity (Id) then 1196 elsif Is_Ignored_Ghost_Entity (Id) then
1132 Install_Ghost_Mode (Ignore); 1197 Install_Ghost_Region (Ignore, N);
1133 1198
1134 Set_Is_Ignored_Ghost_Node (N); 1199 Set_Is_Ignored_Ghost_Node (N);
1135 Propagate_Ignored_Ghost_Code (N); 1200 Record_Ignored_Ghost_Node (N);
1136 end if; 1201 end if;
1137 end if; 1202 end if;
1138 end Mark_And_Set_Ghost_Assignment; 1203 end Mark_And_Set_Ghost_Assignment;
1139 1204
1140 ----------------------------- 1205 -----------------------------
1184 1249
1185 -- Mark the body as its formals as Ghost 1250 -- Mark the body as its formals as Ghost
1186 1251
1187 Mark_Ghost_Declaration_Or_Body (N, Policy); 1252 Mark_Ghost_Declaration_Or_Body (N, Policy);
1188 1253
1189 -- Install the appropriate Ghost mode 1254 -- Install the appropriate Ghost region
1190 1255
1191 Install_Ghost_Mode (Policy); 1256 Install_Ghost_Region (Policy, N);
1192 end Mark_And_Set_Ghost_Body; 1257 end Mark_And_Set_Ghost_Body;
1193 1258
1194 ----------------------------------- 1259 -----------------------------------
1195 -- Mark_And_Set_Ghost_Completion -- 1260 -- Mark_And_Set_Ghost_Completion --
1196 ----------------------------------- 1261 -----------------------------------
1231 1296
1232 -- Mark the completion as Ghost 1297 -- Mark the completion as Ghost
1233 1298
1234 Mark_Ghost_Declaration_Or_Body (N, Policy); 1299 Mark_Ghost_Declaration_Or_Body (N, Policy);
1235 1300
1236 -- Install the appropriate Ghost mode 1301 -- Install the appropriate Ghost region
1237 1302
1238 Install_Ghost_Mode (Policy); 1303 Install_Ghost_Region (Policy, N);
1239 end Mark_And_Set_Ghost_Completion; 1304 end Mark_And_Set_Ghost_Completion;
1240 1305
1241 ------------------------------------ 1306 ------------------------------------
1242 -- Mark_And_Set_Ghost_Declaration -- 1307 -- Mark_And_Set_Ghost_Declaration --
1243 ------------------------------------ 1308 ------------------------------------
1288 1353
1289 -- Mark the declaration and its formals as Ghost 1354 -- Mark the declaration and its formals as Ghost
1290 1355
1291 Mark_Ghost_Declaration_Or_Body (N, Policy); 1356 Mark_Ghost_Declaration_Or_Body (N, Policy);
1292 1357
1293 -- Install the appropriate Ghost mode 1358 -- Install the appropriate Ghost region
1294 1359
1295 Install_Ghost_Mode (Policy); 1360 Install_Ghost_Region (Policy, N);
1296 end Mark_And_Set_Ghost_Declaration; 1361 end Mark_And_Set_Ghost_Declaration;
1297 1362
1298 -------------------------------------- 1363 --------------------------------------
1299 -- Mark_And_Set_Ghost_Instantiation -- 1364 -- Mark_And_Set_Ghost_Instantiation --
1300 -------------------------------------- 1365 --------------------------------------
1368 1433
1369 -- Mark the instantiation as Ghost 1434 -- Mark the instantiation as Ghost
1370 1435
1371 Mark_Ghost_Declaration_Or_Body (N, Policy); 1436 Mark_Ghost_Declaration_Or_Body (N, Policy);
1372 1437
1373 -- Install the appropriate Ghost mode 1438 -- Install the appropriate Ghost region
1374 1439
1375 Install_Ghost_Mode (Policy); 1440 Install_Ghost_Region (Policy, N);
1376 1441
1377 -- Check ghost actuals. Given that this routine is unconditionally 1442 -- Check Ghost actuals. Given that this routine is unconditionally
1378 -- invoked with subprogram and package instantiations, this check 1443 -- invoked with subprogram and package instantiations, this check
1379 -- verifies the context of all the ghost entities passed in generic 1444 -- verifies the context of all the ghost entities passed in generic
1380 -- instantiations. 1445 -- instantiations.
1381 1446
1382 Check_Ghost_Actuals; 1447 Check_Ghost_Actuals;
1395 1460
1396 Id := Ghost_Entity (Name (N)); 1461 Id := Ghost_Entity (Name (N));
1397 1462
1398 if Present (Id) then 1463 if Present (Id) then
1399 if Is_Checked_Ghost_Entity (Id) then 1464 if Is_Checked_Ghost_Entity (Id) then
1400 Install_Ghost_Mode (Check); 1465 Install_Ghost_Region (Check, N);
1401 1466
1402 elsif Is_Ignored_Ghost_Entity (Id) then 1467 elsif Is_Ignored_Ghost_Entity (Id) then
1403 Install_Ghost_Mode (Ignore); 1468 Install_Ghost_Region (Ignore, N);
1404 1469
1405 Set_Is_Ignored_Ghost_Node (N); 1470 Set_Is_Ignored_Ghost_Node (N);
1406 Propagate_Ignored_Ghost_Code (N); 1471 Record_Ignored_Ghost_Node (N);
1407 end if; 1472 end if;
1408 end if; 1473 end if;
1409 end Mark_And_Set_Ghost_Procedure_Call; 1474 end Mark_And_Set_Ghost_Procedure_Call;
1475
1476 -----------------------
1477 -- Mark_Ghost_Clause --
1478 -----------------------
1479
1480 procedure Mark_Ghost_Clause (N : Node_Id) is
1481 Nam : Node_Id := Empty;
1482
1483 begin
1484 if Nkind (N) = N_Use_Package_Clause then
1485 Nam := Name (N);
1486
1487 elsif Nkind (N) = N_Use_Type_Clause then
1488 Nam := Subtype_Mark (N);
1489
1490 elsif Nkind (N) = N_With_Clause then
1491 Nam := Name (N);
1492 end if;
1493
1494 if Present (Nam)
1495 and then Is_Entity_Name (Nam)
1496 and then Present (Entity (Nam))
1497 and then Is_Ignored_Ghost_Entity (Entity (Nam))
1498 then
1499 Set_Is_Ignored_Ghost_Node (N);
1500 Record_Ignored_Ghost_Node (N);
1501 end if;
1502 end Mark_Ghost_Clause;
1410 1503
1411 ------------------------------------ 1504 ------------------------------------
1412 -- Mark_Ghost_Declaration_Or_Body -- 1505 -- Mark_Ghost_Declaration_Or_Body --
1413 ------------------------------------ 1506 ------------------------------------
1414 1507
1431 1524
1432 elsif Mode = Name_Ignore then 1525 elsif Mode = Name_Ignore then
1433 Mark_Formals := True; 1526 Mark_Formals := True;
1434 Set_Is_Ignored_Ghost_Entity (Id); 1527 Set_Is_Ignored_Ghost_Entity (Id);
1435 Set_Is_Ignored_Ghost_Node (N); 1528 Set_Is_Ignored_Ghost_Node (N);
1436 Propagate_Ignored_Ghost_Code (N); 1529 Record_Ignored_Ghost_Node (N);
1437 end if; 1530 end if;
1438 1531
1439 -- Mark all formal parameters when the related node denotes a subprogram 1532 -- Mark all formal parameters when the related node denotes a subprogram
1440 -- or a body. The traversal is performed via the specification because 1533 -- or a body. The traversal is performed via the specification because
1441 -- the related subprogram or body may be unanalyzed. 1534 -- the related subprogram or body may be unanalyzed.
1467 end loop; 1560 end loop;
1468 end if; 1561 end if;
1469 end Mark_Ghost_Declaration_Or_Body; 1562 end Mark_Ghost_Declaration_Or_Body;
1470 1563
1471 ----------------------- 1564 -----------------------
1472 -- Mark_Ghost_Clause --
1473 -----------------------
1474
1475 procedure Mark_Ghost_Clause (N : Node_Id) is
1476 Nam : Node_Id := Empty;
1477
1478 begin
1479 if Nkind (N) = N_Use_Package_Clause then
1480 Nam := Name (N);
1481
1482 elsif Nkind (N) = N_Use_Type_Clause then
1483 Nam := Subtype_Mark (N);
1484
1485 elsif Nkind (N) = N_With_Clause then
1486 Nam := Name (N);
1487 end if;
1488
1489 if Present (Nam)
1490 and then Is_Entity_Name (Nam)
1491 and then Present (Entity (Nam))
1492 and then Is_Ignored_Ghost_Entity (Entity (Nam))
1493 then
1494 Set_Is_Ignored_Ghost_Node (N);
1495 Propagate_Ignored_Ghost_Code (N);
1496 end if;
1497 end Mark_Ghost_Clause;
1498
1499 -----------------------
1500 -- Mark_Ghost_Pragma -- 1565 -- Mark_Ghost_Pragma --
1501 ----------------------- 1566 -----------------------
1502 1567
1503 procedure Mark_Ghost_Pragma 1568 procedure Mark_Ghost_Pragma
1504 (N : Node_Id; 1569 (N : Node_Id;
1512 Set_Is_Checked_Ghost_Pragma (N); 1577 Set_Is_Checked_Ghost_Pragma (N);
1513 1578
1514 elsif Is_Ignored_Ghost_Entity (Id) then 1579 elsif Is_Ignored_Ghost_Entity (Id) then
1515 Set_Is_Ignored_Ghost_Pragma (N); 1580 Set_Is_Ignored_Ghost_Pragma (N);
1516 Set_Is_Ignored_Ghost_Node (N); 1581 Set_Is_Ignored_Ghost_Node (N);
1517 Propagate_Ignored_Ghost_Code (N); 1582 Record_Ignored_Ghost_Node (N);
1518 end if; 1583 end if;
1519 end Mark_Ghost_Pragma; 1584 end Mark_Ghost_Pragma;
1520 1585
1521 ------------------------- 1586 -------------------------
1522 -- Mark_Ghost_Renaming -- 1587 -- Mark_Ghost_Renaming --
1539 end if; 1604 end if;
1540 1605
1541 Mark_Ghost_Declaration_Or_Body (N, Policy); 1606 Mark_Ghost_Declaration_Or_Body (N, Policy);
1542 end Mark_Ghost_Renaming; 1607 end Mark_Ghost_Renaming;
1543 1608
1544 ---------------------------------- 1609 ------------------------
1545 -- Propagate_Ignored_Ghost_Code -- 1610 -- Name_To_Ghost_Mode --
1546 ---------------------------------- 1611 ------------------------
1547 1612
1548 procedure Propagate_Ignored_Ghost_Code (N : Node_Id) is 1613 function Name_To_Ghost_Mode (Mode : Name_Id) return Ghost_Mode_Type is
1549 Nod : Node_Id; 1614 begin
1550 Scop : Entity_Id; 1615 if Mode = Name_Check then
1551 1616 return Check;
1552 begin 1617
1553 -- Traverse the parent chain looking for blocks, packages, and 1618 elsif Mode = Name_Ignore then
1554 -- subprograms or their respective bodies. 1619 return Ignore;
1555 1620
1556 Nod := Parent (N); 1621 -- Otherwise the mode must denote one of the following:
1557 while Present (Nod) loop 1622 --
1558 Scop := Empty; 1623 -- * Disable indicates that the Ghost policy in effect is Disable
1559 1624 --
1560 if Nkind (Nod) = N_Block_Statement 1625 -- * None or No_Name indicates that the associated construct is not
1561 and then Present (Identifier (Nod)) 1626 -- subject to any Ghost annotation.
1562 then 1627
1563 Scop := Entity (Identifier (Nod)); 1628 else
1564 1629 pragma Assert (Nam_In (Mode, Name_Disable, Name_None, No_Name));
1565 elsif Nkind_In (Nod, N_Package_Body, 1630 return None;
1566 N_Package_Declaration, 1631 end if;
1567 N_Subprogram_Body, 1632 end Name_To_Ghost_Mode;
1568 N_Subprogram_Declaration) 1633
1569 then 1634 -------------------------------
1570 Scop := Defining_Entity (Nod); 1635 -- Record_Ignored_Ghost_Node --
1571 end if; 1636 -------------------------------
1572 1637
1573 -- The current node denotes a scoping construct 1638 procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id) is
1574 1639 begin
1575 if Present (Scop) then 1640 -- Save all "top level" ignored Ghost nodes which can be safely replaced
1576 1641 -- with a null statement. Note that there is need to save other kinds of
1577 -- Stop the traversal when the scope already contains ignored 1642 -- nodes because those will always be enclosed by some top level ignored
1578 -- Ghost code as all enclosing scopes have already been marked. 1643 -- Ghost node.
1579 1644
1580 if Contains_Ignored_Ghost_Code (Scop) then 1645 if Is_Body (N)
1581 exit; 1646 or else Is_Declaration (N)
1582 1647 or else Nkind (N) in N_Generic_Instantiation
1583 -- Otherwise mark this scope and keep climbing 1648 or else Nkind (N) in N_Push_Pop_xxx_Label
1584 1649 or else Nkind (N) in N_Raise_xxx_Error
1585 else 1650 or else Nkind (N) in N_Representation_Clause
1586 Set_Contains_Ignored_Ghost_Code (Scop); 1651 or else Nkind_In (N, N_Assignment_Statement,
1587 end if; 1652 N_Call_Marker,
1588 end if; 1653 N_Freeze_Entity,
1589 1654 N_Freeze_Generic_Entity,
1590 Nod := Parent (Nod); 1655 N_Itype_Reference,
1591 end loop; 1656 N_Pragma,
1592 1657 N_Procedure_Call_Statement,
1593 -- The unit containing the ignored Ghost code must be post processed 1658 N_Use_Package_Clause,
1594 -- before invoking the back end. 1659 N_Use_Type_Clause,
1595 1660 N_Variable_Reference_Marker,
1596 Add_Ignored_Ghost_Unit (Cunit (Get_Code_Unit (N))); 1661 N_With_Clause)
1597 end Propagate_Ignored_Ghost_Code; 1662 then
1663 -- Only ignored Ghost nodes must be recorded in the table
1664
1665 pragma Assert (Is_Ignored_Ghost_Node (N));
1666 Ignored_Ghost_Nodes.Append (N);
1667 end if;
1668 end Record_Ignored_Ghost_Node;
1598 1669
1599 ------------------------------- 1670 -------------------------------
1600 -- Remove_Ignored_Ghost_Code -- 1671 -- Remove_Ignored_Ghost_Code --
1601 ------------------------------- 1672 -------------------------------
1602 1673
1603 procedure Remove_Ignored_Ghost_Code is 1674 procedure Remove_Ignored_Ghost_Code is
1604 procedure Prune_Tree (Root : Node_Id); 1675 procedure Remove_Ignored_Ghost_Node (N : Node_Id);
1605 -- Remove all code marked as ignored Ghost from the tree of denoted by 1676 -- Eliminate ignored Ghost node N from the tree
1606 -- Root. 1677
1607 1678 -------------------------------
1608 ---------------- 1679 -- Remove_Ignored_Ghost_Node --
1609 -- Prune_Tree -- 1680 -------------------------------
1610 ---------------- 1681
1611 1682 procedure Remove_Ignored_Ghost_Node (N : Node_Id) is
1612 procedure Prune_Tree (Root : Node_Id) is 1683 begin
1613 procedure Prune (N : Node_Id); 1684 -- The generation and processing of ignored Ghost nodes may cause the
1614 -- Remove a given node from the tree by rewriting it into null 1685 -- same node to be saved multiple times. Reducing the number of saves
1615 1686 -- to one involves costly solutions such as a hash table or the use
1616 function Prune_Node (N : Node_Id) return Traverse_Result; 1687 -- of a flag shared by all nodes. To solve this problem, the removal
1617 -- Determine whether node N denotes an ignored Ghost construct. If 1688 -- machinery allows for multiple saves, but does not eliminate a node
1618 -- this is the case, rewrite N as a null statement. See the body for 1689 -- which has already been eliminated.
1619 -- special cases. 1690
1620 1691 if Nkind (N) = N_Null_Statement then
1621 ----------- 1692 null;
1622 -- Prune -- 1693
1623 ----------- 1694 -- Otherwise the ignored Ghost node must be eliminated
1624 1695
1625 procedure Prune (N : Node_Id) is 1696 else
1626 begin 1697 -- Only ignored Ghost nodes must be eliminated from the tree
1627 -- Destroy any aspects that may be associated with the node 1698
1628 1699 pragma Assert (Is_Ignored_Ghost_Node (N));
1629 if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then 1700
1630 Remove_Aspects (N); 1701 -- Eliminate the node by rewriting it into null. Another option
1631 end if; 1702 -- is to remove it from the tree, however multiple corner cases
1703 -- emerge which have be dealt individually.
1632 1704
1633 Rewrite (N, Make_Null_Statement (Sloc (N))); 1705 Rewrite (N, Make_Null_Statement (Sloc (N)));
1634 end Prune; 1706
1635 1707 -- Eliminate any aspects hanging off the ignored Ghost node
1636 ---------------- 1708
1637 -- Prune_Node -- 1709 Remove_Aspects (N);
1638 ---------------- 1710 end if;
1639 1711 end Remove_Ignored_Ghost_Node;
1640 function Prune_Node (N : Node_Id) return Traverse_Result is
1641 Id : Entity_Id;
1642
1643 begin
1644 -- Do not prune compilation unit nodes because many mechanisms
1645 -- depend on their presence. Note that context items are still
1646 -- being processed.
1647
1648 if Nkind (N) = N_Compilation_Unit then
1649 return OK;
1650
1651 -- The node is either declared as ignored Ghost or is a byproduct
1652 -- of expansion. Destroy it and stop the traversal on this branch.
1653
1654 elsif Is_Ignored_Ghost_Node (N) then
1655 Prune (N);
1656 return Skip;
1657
1658 -- Scoping constructs such as blocks, packages, subprograms and
1659 -- bodies offer some flexibility with respect to pruning.
1660
1661 elsif Nkind_In (N, N_Block_Statement,
1662 N_Package_Body,
1663 N_Package_Declaration,
1664 N_Subprogram_Body,
1665 N_Subprogram_Declaration)
1666 then
1667 if Nkind (N) = N_Block_Statement then
1668 Id := Entity (Identifier (N));
1669 else
1670 Id := Defining_Entity (N);
1671 end if;
1672
1673 -- The scoping construct contains both living and ignored Ghost
1674 -- code, let the traversal prune all relevant nodes.
1675
1676 if Contains_Ignored_Ghost_Code (Id) then
1677 return OK;
1678
1679 -- Otherwise the construct contains only living code and should
1680 -- not be pruned.
1681
1682 else
1683 return Skip;
1684 end if;
1685
1686 -- Otherwise keep searching for ignored Ghost nodes
1687
1688 else
1689 return OK;
1690 end if;
1691 end Prune_Node;
1692
1693 procedure Prune_Nodes is new Traverse_Proc (Prune_Node);
1694
1695 -- Start of processing for Prune_Tree
1696
1697 begin
1698 Prune_Nodes (Root);
1699 end Prune_Tree;
1700 1712
1701 -- Start of processing for Remove_Ignored_Ghost_Code 1713 -- Start of processing for Remove_Ignored_Ghost_Code
1702 1714
1703 begin 1715 begin
1704 for Index in Ignored_Ghost_Units.First .. Ignored_Ghost_Units.Last loop 1716 for Index in Ignored_Ghost_Nodes.First .. Ignored_Ghost_Nodes.Last loop
1705 Prune_Tree (Ignored_Ghost_Units.Table (Index)); 1717 Remove_Ignored_Ghost_Node (Ignored_Ghost_Nodes.Table (Index));
1706 end loop; 1718 end loop;
1707 end Remove_Ignored_Ghost_Code; 1719 end Remove_Ignored_Ghost_Code;
1708 1720
1709 ------------------------ 1721 --------------------------
1710 -- Restore_Ghost_Mode -- 1722 -- Restore_Ghost_Region --
1711 ------------------------ 1723 --------------------------
1712 1724
1713 procedure Restore_Ghost_Mode (Mode : Ghost_Mode_Type) is 1725 procedure Restore_Ghost_Region (Mode : Ghost_Mode_Type; N : Node_Id) is
1714 begin 1726 begin
1715 Ghost_Mode := Mode; 1727 Ghost_Mode := Mode;
1716 end Restore_Ghost_Mode; 1728 Ignored_Ghost_Region := N;
1729 end Restore_Ghost_Region;
1717 1730
1718 -------------------- 1731 --------------------
1719 -- Set_Ghost_Mode -- 1732 -- Set_Ghost_Mode --
1720 -------------------- 1733 --------------------
1721 1734