yggdrasil/gcc
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[Ada] Extend No_Dependence restriction to code generation

Browse Source 
This makes it possible to report violations of the No_Dependence restriction
during code generation, in other words outside of the Ada front-end proper.
These violations are supposed to be only for child units of System, so the
implementation is restricted to these cases.

gcc/ada/

	* restrict.ads (type ND_Entry): Add System_Child component.
	(Check_Restriction_No_Dependence_On_System): Declare.
	* restrict.adb (Global_Restriction_No_Tasking): Move around.
	(Violation_Of_No_Dependence): New procedure.
	(Check_Restriction_No_Dependence): Call Violation_Of_No_Dependence
	to report a violation.
	(Check_Restriction_No_Dependence_On_System): New procedure.
	(Set_Restriction_No_Dependenc): Set System_Child component if the
	unit is a child of System.
	* snames.ads-tmpl (Name_Arith_64): New package name.
	(Name_Arith_128): Likewise.
	(Name_Memory): Likewise.
	(Name_Stack_Checking): Likewise.
	* fe.h (Check_Restriction_No_Dependence_On_System): Declare.
This commit is contained in:
Eric Botcazou
2022-06-28 18:51:30 +02:00
committed by Pierre-Marie de Rodat
parent 0ff936fe86
commit 433cefcd02
4 changed files with 89 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
gcc/ada/fe.h
+3
View File
@@ -252,6 +252,8 @@ extern Boolean SJLJ_Exceptions (void);
restrict__check_no_implicit_protected_alloc
#define Check_No_Implicit_Task_Alloc \
restrict__check_no_implicit_task_alloc
#define Check_Restriction_No_Dependence_On_System \
restrict__check_restriction_no_dependence_on_system
#define No_Exception_Handlers_Set \
restrict__no_exception_handlers_set
#define No_Exception_Propagation_Active \
@@ -262,6 +264,7 @@ extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id);
extern void Check_No_Implicit_Heap_Alloc (Node_Id);
extern void Check_No_Implicit_Protected_Alloc (Node_Id);
extern void Check_No_Implicit_Task_Alloc (Node_Id);
extern void Check_Restriction_No_Dependence_On_System (Name_Id, Node_Id);
extern Boolean No_Exception_Handlers_Set (void);
extern Boolean No_Exception_Propagation_Active (void);
gcc/ada/restrict.adb
+72 -23
View File
@@ -44,10 +44,6 @@ with Uname; use Uname;
package body Restrict is
Global_Restriction_No_Tasking : Boolean := False;
-- Set to True when No_Tasking is set in the run-time package System
-- or in a configuration pragmas file (for example, gnat.adc).
--------------------------------
-- Package Local Declarations --
--------------------------------
@@ -55,6 +51,10 @@ package body Restrict is
Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
-- Save compilation unit restrictions set by config pragma files
Global_Restriction_No_Tasking : Boolean := False;
-- Set to True when No_Tasking is set in the run-time package System
-- or in a configuration pragmas file (for example, gnat.adc).
Restricted_Profile_Result : Boolean := False;
-- This switch memoizes the result of Restricted_Profile function calls for
-- improved efficiency. Valid only if Restricted_Profile_Cached is True.
@@ -122,6 +122,11 @@ package body Restrict is
-- message is to be suppressed if this is an internal file and this file is
-- not the main unit. Returns True if message is to be suppressed.
procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id);
-- Called if a violation of restriction No_Dependence for Unit at node N
-- is found. This routine outputs the appropriate message, taking care of
-- warning vs real violation.
-------------------
-- Abort_Allowed --
-------------------
@@ -550,8 +555,6 @@ package body Restrict is
-------------------------------------
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
DU : Node_Id;
begin
-- Ignore call if node U is not in the main source unit. This avoids
-- cascaded errors, e.g. when Ada.Containers units with other units.
@@ -567,27 +570,34 @@ package body Restrict is
-- Loop through entries in No_Dependence table to check each one in turn
for J in No_Dependences.First .. No_Dependences.Last loop
DU := No_Dependences.Table (J).Unit;
if Same_Unit (U, DU) then
Error_Msg_Sloc := Sloc (DU);
Error_Msg_Node_1 := DU;
if No_Dependences.Table (J).Warn then
Error_Msg
("?*?violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
else
Error_Msg
("|violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
end if;
if Same_Unit (No_Dependences.Table (J).Unit, U) then
Violation_Of_No_Dependence (J, Err);
return;
end if;
end loop;
end Check_Restriction_No_Dependence;
-----------------------------------------------
-- Check_Restriction_No_Dependence_On_System --
-----------------------------------------------
procedure Check_Restriction_No_Dependence_On_System
(U : Name_Id;
Err : Node_Id)
is
pragma Assert (U /= No_Name);
begin
-- Loop through entries in No_Dependence table to check each one in turn
for J in No_Dependences.First .. No_Dependences.Last loop
if No_Dependences.Table (J).System_Child = U then
Violation_Of_No_Dependence (J, Err);
return;
end if;
end loop;
end Check_Restriction_No_Dependence_On_System;
--------------------------------------------------
-- Check_Restriction_No_Specification_Of_Aspect --
--------------------------------------------------
@@ -1474,6 +1484,8 @@ package body Restrict is
Warn : Boolean;
Profile : Profile_Name := No_Profile)
is
ND : ND_Entry;
begin
-- Loop to check for duplicate entry
@@ -1495,7 +1507,26 @@ package body Restrict is
-- Entry is not currently in table
No_Dependences.Append ((Unit, Warn, Profile));
ND := (Unit, No_Name, Warn, Profile);
-- Check whether this is a child unit of System
if Nkind (Unit) = N_Selected_Component then
declare
Root : Node_Id := Unit;
begin
while Nkind (Prefix (Root)) = N_Selected_Component loop
Root := Prefix (Root);
end loop;
if Chars (Prefix (Root)) = Name_System then
ND.System_Child := Chars (Selector_Name (Root));
end if;
end;
end if;
No_Dependences.Append (ND);
end Set_Restriction_No_Dependence;
--------------------------------------
@@ -1647,6 +1678,24 @@ package body Restrict is
end if;
end Suppress_Restriction_Message;
--------------------------------
-- Violation_Of_No_Dependence --
--------------------------------
procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id) is
begin
Error_Msg_Node_1 := No_Dependences.Table (Unit).Unit;
Error_Msg_Sloc := Sloc (Error_Msg_Node_1);
if No_Dependences.Table (Unit).Warn then
Error_Msg
("?*?violation of restriction `No_Dependence '='> &`#", Sloc (N));
else
Error_Msg
("|violation of restriction `No_Dependence '='> &`#", Sloc (N));
end if;
end Violation_Of_No_Dependence;
---------------------
-- Tasking_Allowed --
---------------------
gcc/ada/restrict.ads
+10
View File
@@ -168,6 +168,9 @@ package Restrict is
Unit : Node_Id;
-- The unit parameter from the No_Dependence pragma
System_Child : Name_Id;
-- The name if the unit is a child of System, or else No_Name
Warn : Boolean;
-- True if from Restriction_Warnings, False if from Restrictions
@@ -269,6 +272,13 @@ package Restrict is
-- an explicit WITH clause). U is a node for the unit involved, and Err is
-- the node to which an error will be attached if necessary.
procedure Check_Restriction_No_Dependence_On_System
(U : Name_Id;
Err : Node_Id);
-- Likewise, but for the child units of System referenced by their name
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id);
-- N is the node id for an N_Aspect_Specification, an N_Pragma, or an
-- N_Attribute_Definition_Clause. An error message (warning) will be issued
gcc/ada/snames.ads-tmpl
+4
View File
@@ -274,10 +274,14 @@ package Snames is
-- Names for packages that are treated specially by the compiler
Name_Arith_64 : constant Name_Id := N + $;
Name_Arith_128 : constant Name_Id := N + $;
Name_Exception_Traces : constant Name_Id := N + $;
Name_Finalization : constant Name_Id := N + $;
Name_Interfaces : constant Name_Id := N + $;
Name_Memory : constant Name_Id := N + $;
Name_Most_Recent_Exception : constant Name_Id := N + $;
Name_Stack_Checking : constant Name_Id := N + $;
Name_Standard : constant Name_Id := N + $;
Name_System : constant Name_Id := N + $;
Name_Text_IO : constant Name_Id := N + $;