[Ada] Better enforcement of No_Dynamic_Attachment/No_Abort_Statements
Arnaud Charlet
charlet@adacore.com
Tue Feb 25 15:59:00 GMT 2014
No_Dynamic_Attachment is now enforced in -gnatc mode, and includes
checking for any use of any of the entities, including rename and
access. No_Abort_Statements now checks for any use of Abort_Task,
including renaming. The following test programs are compiled using
-gnatc -gnatj55.
1. pragma Restrictions (No_Dynamic_Attachment);
2. with Ada.Interrupts; use Ada.Interrupts;
3. procedure NoDynAt is
4. X : Interrupt_ID := Interrupt_ID'First;
5. function XXX
6. (Interrupt : Interrupt_Id) return Boolean
7. renames Is_Attached;
|
>>> violation of restriction
"NO_DYNAMIC_ATTACHMENT" at line 1
8. type M is access function
9. (Interrupt : Interrupt_Id) return Boolean;
10. MV : M := Is_Attached'Access;
|
>>> violation of restriction
"NO_DYNAMIC_ATTACHMENT" at line 1
11. begin
12. if Ada.Interrupts.Is_Reserved (X) then
|
>>> violation of restriction
"NO_DYNAMIC_ATTACHMENT" at line 1
13. null;
14. elsif Ada.Interrupts.Is_Attached (X) then
|
>>> violation of restriction
"NO_DYNAMIC_ATTACHMENT" at line 1
15. null;
16. elsif XXX (X) then
17. null;
18. end if;
19. end NoDynAt;
1. pragma Restrictions (No_Abort_Statements);
2. with Ada.Task_Identification;
3. use Ada.Task_Identification;
4. procedure ATI_Abort is
5. procedure XXX (T : Task_Id) renames Abort_Task;
|
>>> violation of restriction
"NO_ABORT_STATEMENTS" at line 1
6. procedure YYY (T : Task_Id);
7. procedure YYY (T : Task_Id) renames Abort_Task;
|
>>> violation of restriction
"NO_ABORT_STATEMENTS" at line 1
8. type R is access procedure (T : Task_Id);
9. RV : R := Abort_Task'Access;
|
>>> violation of restriction
"NO_ABORT_STATEMENTS" at line 1
10. begin
11. Abort_Task (Current_Task);
|
>>> violation of restriction
"NO_ABORT_STATEMENTS" at line 1
12. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-25 Robert Dewar <dewar@adacore.com>
* rtsfind.adb (Is_RTE): Protect against entity with no scope
field (previously this call blew up on the Standard entity).
* sem_attr.adb (Analyze_Attribute, case Access): Remove
test for No_Abort_Statements, this is now handled in
Set_Entity_With_Checks.
* exp_ch6.adb, sem_ch10.adb, sem_ch4.adb, sem_ch8.adb, sem_res.adb:
Change name Set_Entity_With_Style_Check => Set_Entity_With_Checks.
* sem_util.ads, sem_util.adb: Change name Set_Entity_With_Style_Check =>
Set_Entity_With_Checks.
(Set_Entity_With_Checks): Add checks for No_Dynamic_Attachment,
Add checks for No_Abort_Statements.
-------------- next part --------------
Index: sem_ch10.adb
===================================================================
--- sem_ch10.adb (revision 208134)
+++ sem_ch10.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2632,7 +2632,7 @@
-- to consider the unit as unreferenced if this is the only reference
-- that occurs.
- Set_Entity_With_Style_Check (Name (N), E_Name);
+ Set_Entity_With_Checks (Name (N), E_Name);
Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
-- Generate references and check No_Dependence restriction for parents
@@ -2657,7 +2657,7 @@
exit;
end if;
- Set_Entity_With_Style_Check (Pref, Par_Name);
+ Set_Entity_With_Checks (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
Check_Restriction_No_Dependence (Pref, N);
@@ -2697,7 +2697,7 @@
-- Guard against missing or misspelled child units
if Present (Par_Name) then
- Set_Entity_With_Style_Check (Pref, Par_Name);
+ Set_Entity_With_Checks (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
else
Index: rtsfind.adb
===================================================================
--- rtsfind.adb (revision 208067)
+++ rtsfind.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -464,7 +464,7 @@
S := Scope (Ent);
- if Ekind (S) /= E_Package then
+ if No (S) or else Ekind (S) /= E_Package then
return False;
end if;
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 208143)
+++ sem_util.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -15805,19 +15805,59 @@
end if;
end Set_Debug_Info_Needed;
- ---------------------------------
- -- Set_Entity_With_Style_Check --
- ---------------------------------
+ ----------------------------
+ -- Set_Entity_With_Checks --
+ ----------------------------
- procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
+ procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
Val_Actual : Entity_Id;
Nod : Node_Id;
+ Post_Node : Node_Id;
begin
-- Unconditionally set the entity
Set_Entity (N, Val);
+ -- Remaining checks are only done on source nodes
+
+ if not Comes_From_Source (N) then
+ return;
+ end if;
+
+ -- The node to post on is the selector in the case of an expanded name,
+ -- and otherwise the node itself.
+
+ if Nkind (N) = N_Expanded_Name then
+ Post_Node := Selector_Name (N);
+ else
+ Post_Node := N;
+ end if;
+
+ -- Check for violation of No_Abort_Statements, which is triggered by
+ -- call to Ada.Task_Identification.Abort_Task.
+
+ if Restriction_Check_Required (No_Abort_Statements)
+ and then (Is_RTE (Val, RE_Abort_Task))
+ then
+ Check_Restriction (No_Abort_Statements, Post_Node);
+ end if;
+
+ -- Check for violation of No_Dynamic_Attachment
+
+ if Restriction_Check_Required (No_Dynamic_Attachment)
+ and then RTU_Loaded (Ada_Interrupts)
+ and then (Is_RTE (Val, RE_Is_Reserved) or else
+ Is_RTE (Val, RE_Is_Attached) or else
+ Is_RTE (Val, RE_Current_Handler) or else
+ Is_RTE (Val, RE_Attach_Handler) or else
+ Is_RTE (Val, RE_Exchange_Handler) or else
+ Is_RTE (Val, RE_Detach_Handler) or else
+ Is_RTE (Val, RE_Reference))
+ then
+ Check_Restriction (No_Dynamic_Attachment, Post_Node);
+ end if;
+
-- Check for No_Implementation_Identifiers
if Restriction_Check_Required (No_Implementation_Identifiers) then
@@ -15834,7 +15874,7 @@
and then not (Ekind_In (Val, E_Package, E_Generic_Package)
and then Is_Library_Level_Entity (Val))
then
- Check_Restriction (No_Implementation_Identifiers, N);
+ Check_Restriction (No_Implementation_Identifiers, Post_Node);
end if;
end if;
@@ -15877,7 +15917,7 @@
end if;
Set_Entity (N, Val);
- end Set_Entity_With_Style_Check;
+ end Set_Entity_With_Checks;
------------------------
-- Set_Name_Entity_Id --
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 208143)
+++ sem_util.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1765,11 +1765,22 @@
-- This routine should always be used instead of Set_Needs_Debug_Info to
-- ensure that subsidiary entities are properly handled.
- procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id);
- -- This procedure has the same calling sequence as Set_Entity, but
- -- if Style_Check is set, then it calls a style checking routine which
- -- can check identifier spelling style. This procedure also takes care
- -- of checking the restriction No_Implementation_Identifiers.
+ procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id);
+ -- This procedure has the same calling sequence as Set_Entity, but it
+ -- performs additional checks as follows:
+ --
+ -- If Style_Check is set, then it calls a style checking routine which
+ -- can check identifier spelling style. This procedure also takes care
+ -- of checking the restriction No_Implementation_Identifiers.
+ --
+ -- If restriction No_Abort_Statements is set, then it checks that the
+ -- entity is not Ada.Task_Identification.Abort_Task.
+ --
+ -- If restriction No_Dynamic_Attachment is set, then it checks that the
+ -- entity is not one of the restricted names for this restriction.
+ --
+ -- If restriction No_Implementation_Identifiers is set, then it checks
+ -- that the entity is not implementation defined.
procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
pragma Inline (Set_Name_Entity_Id);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 208146)
+++ sem_res.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -5406,19 +5406,8 @@
elsif not (Is_Type (Entity (Subp))) then
Nam := Entity (Subp);
- Set_Entity_With_Style_Check (Subp, Nam);
+ Set_Entity_With_Checks (Subp, Nam);
- -- Check restriction No_Abort_Statements, which is triggered by a
- -- call to Ada.Task_Identification.Abort_Task.
-
- if Restriction_Check_Required (No_Abort_Statements)
- and then (Is_RTE (Nam, RE_Abort_Task)
- or else (Present (Alias (Nam))
- and then Is_RTE (Alias (Nam), RE_Abort_Task)))
- then
- Check_Restriction (No_Abort_Statements, N);
- end if;
-
-- Otherwise we must have the case of an overloaded call
else
@@ -5433,7 +5422,7 @@
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Nam := It.Nam;
- Set_Entity_With_Style_Check (Subp, Nam);
+ Set_Entity_With_Checks (Subp, Nam);
exit;
end if;
@@ -6235,7 +6224,7 @@
C := Current_Entity (N);
while Present (C) loop
if Etype (C) = B_Typ then
- Set_Entity_With_Style_Check (N, C);
+ Set_Entity_With_Checks (N, C);
Generate_Reference (C, N);
return;
end if;
@@ -6507,7 +6496,7 @@
-- not do a style check during the first phase of analysis.
elsif Ekind (E) = E_Enumeration_Literal then
- Set_Entity_With_Style_Check (N, E);
+ Set_Entity_With_Checks (N, E);
Eval_Entity_Name (N);
-- Case of subtype name appearing as an operand in expression
@@ -9226,7 +9215,7 @@
Resolve (P, It1.Typ);
Set_Etype (N, Typ);
- Set_Entity_With_Style_Check (S, Comp1);
+ Set_Entity_With_Checks (S, Comp1);
else
-- Resolve prefix with its type
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 208146)
+++ sem_attr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -9645,9 +9645,7 @@
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access =>
- Access_Attribute : declare
- Nam : Entity_Id;
-
+ Access_Attribute :
begin
if Is_Variable (P) then
Note_Possible_Modification (P, Sure => False);
@@ -9692,7 +9690,6 @@
-- If it is an object, complete its resolution.
elsif Is_Overloadable (Entity (P)) then
- Nam := Entity (P);
-- Avoid insertion of freeze actions in spec expression mode
@@ -9700,18 +9697,6 @@
Freeze_Before (N, Entity (P));
end if;
- -- Forbid access to Abort_Task if restriction active
-
- if Restriction_Check_Required (No_Abort_Statements)
- and then
- (Is_RTE (Nam, RE_Abort_Task)
- or else
- (Present (Alias (Nam))
- and then Is_RTE (Alias (Nam), RE_Abort_Task)))
- then
- Check_Restriction (No_Abort_Statements, N);
- end if;
-
elsif Is_Type (Entity (P)) then
null;
else
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 208146)
+++ exp_ch6.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3641,21 +3641,6 @@
Subp := Parent_Subp;
end if;
- -- Check for violation of No_Dynamic_Attachment
-
- if Restriction_Check_Required (No_Dynamic_Attachment)
- and then RTU_Loaded (Ada_Interrupts)
- and then (Is_RTE (Subp, RE_Is_Reserved) or else
- Is_RTE (Subp, RE_Is_Attached) or else
- Is_RTE (Subp, RE_Current_Handler) or else
- Is_RTE (Subp, RE_Attach_Handler) or else
- Is_RTE (Subp, RE_Exchange_Handler) or else
- Is_RTE (Subp, RE_Detach_Handler) or else
- Is_RTE (Subp, RE_Reference))
- then
- Check_Restriction (No_Dynamic_Attachment, Call_Node);
- end if;
-
-- Deal with case where call is an explicit dereference
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 208135)
+++ sem_ch4.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1298,7 +1298,7 @@
-- Resolution yields a single interpretation. Verify that the
-- reference has capitalization consistent with the declaration.
- Set_Entity_With_Style_Check (Nam, Entity (Nam));
+ Set_Entity_With_Checks (Nam, Entity (Nam));
Generate_Reference (Entity (Nam), Nam);
Set_Etype (Nam, Etype (Entity (Nam)));
@@ -3503,7 +3503,7 @@
if Is_Overloadable (Comp) then
Add_One_Interp (Sel, Comp, Etype (Comp));
else
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Generate_Reference (Comp, Sel);
end if;
@@ -4002,7 +4002,7 @@
Comp := First_Component (Rec);
while Present (Comp) loop
if Chars (Comp) = Chars (Sel) then
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
return;
@@ -4239,7 +4239,7 @@
if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp, N)
then
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
if Ekind (Comp) = E_Discriminant then
@@ -4420,7 +4420,7 @@
while Present (Comp) loop
if Chars (Comp) = Chars (Sel) then
if Ekind (Comp) = E_Discriminant then
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Generate_Reference (Comp, Sel);
Set_Etype (Sel, Etype (Comp));
@@ -4497,7 +4497,7 @@
and then not Is_Protected_Type (Prefix_Type)
and then Is_Entity_Name (Name))
then
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Generate_Reference (Comp, Sel);
-- The selector is not overloadable, so we have a candidate
@@ -4706,7 +4706,7 @@
if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp)
then
- Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Entity_With_Checks (Sel, Comp);
Generate_Reference (Comp, Sel);
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 208067)
+++ sem_ch8.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3664,7 +3664,7 @@
or else Ekind (E) /= E_Discriminant
or else Inside_A_Generic
then
- Set_Entity_With_Style_Check (N, E);
+ Set_Entity_With_Checks (N, E);
-- The replacement of a discriminant by the corresponding discriminal
-- is not done for a task discriminant that appears in a default
@@ -5058,16 +5058,16 @@
end if;
-- Set the entity. Note that the reason we call Set_Entity for the
- -- overloadable case, as opposed to Set_Entity_With_Style_Check is
+ -- overloadable case, as opposed to Set_Entity_With_Checks is
-- that in the overloaded case, the initial call can set the wrong
-- homonym. The call that sets the right homonym is in Sem_Res and
- -- that call does use Set_Entity_With_Style_Check, so we don't miss
+ -- that call does use Set_Entity_With_Checks, so we don't miss
-- a style check.
if Is_Overloadable (E) then
Set_Entity (N, E);
else
- Set_Entity_With_Style_Check (N, E);
+ Set_Entity_With_Checks (N, E);
end if;
if Is_Type (E) then
@@ -6579,7 +6579,7 @@
C := Class_Wide_Type (Entity (Prefix (N)));
end if;
- Set_Entity_With_Style_Check (N, C);
+ Set_Entity_With_Checks (N, C);
Generate_Reference (C, N);
Set_Etype (N, C);
end if;
More information about the Gcc-patches
mailing list