This update allows the use of the following restrictions pragmas
in package System:
No_Specification_Of_Aspect
No_Use_Of_Attribute
No_Use_Of_Pragma
Given a system.ads file containing the lines:
pragma Restrictions (No_Use_Of_Pragma => Attach_Handler);
pragma Restrictions (No_Specification_Of_Aspect => Size);
pragma Restrictions (No_Use_Of_Attribute => Alignment);
The following test compiles as shown (using -gnatj55)
1. package ATHandT is
2. protected X is
3. procedure handler;
4. pragma Attach_Handler (Handler, 0);
|
>>> violation of restriction "No_Use_Of_Pragma
=> Attach_Handler" in package System
5. end X;
6. M : Integer with Size => 32;
|
>>> violation of restriction
"No_Specification_Of_Aspect => Size" at
system.ads:3
7. N : Integer;
8. for N'Alignment use 4;
|
>>> violation of restriction
"No_Use_Of_Attribute => alignment" at
system.ads:4
9. end ATHandT;
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-05-26 Robert Dewar <de...@adacore.com>
* gnat1drv.adb (Gnat1drv): Provide new arguments for
Get_Target_Parameters.
* restrict.adb (Set_Restriction_No_Specification_Of_Aspect):
new procedure.
(Set_Restriction_No_Use_Of_Attribute): new procedure.
* restrict.ads (Set_Restriction_No_Specification_Of_Aspect):
new procedure.
(Set_Restriction_No_Use_Of_Attribute): new procedure.
* s-rident.ads (Integer_Parameter_Restrictions): New subtype.
* targparm.adb (Get_Target_Parameters): Allow new restriction
pragmas No_Specification_Of_Aspect No_Use_Of_Attribute
No_Use_Of_Pragma.
* targparm.ads: New parameters for Get_Target_Parameters.
* tbuild.adb (Set_NOD): New name for Set_RND.
(Set_NSA): New procedure.
(Set_NUA): New procedure.
(Set_NUP): New procedure.
* tbuild.ads (Make_SC): Minor reformatting.
(Set_NOD): New name for Set_RND.
(Set_NSA, Set_NUA, Set_NUP): New procedure.
Index: tbuild.adb
===================================================================
--- tbuild.adb (revision 223661)
+++ tbuild.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Aspects; use Aspects;
with Csets; use Csets;
with Einfo; use Einfo;
with Elists; use Elists;
@@ -779,14 +780,57 @@
end OK_Convert_To;
-------------
- -- Set_RND --
+ -- Set_NOD --
-------------
- procedure Set_RND (Unit : Node_Id) is
+ procedure Set_NOD (Unit : Node_Id) is
begin
Set_Restriction_No_Dependence (Unit, Warn => False);
- end Set_RND;
+ end Set_NOD;
+ -------------
+ -- Set_NSA --
+ -------------
+
+ procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is
+ Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
+ begin
+ if Asp_Id = No_Aspect then
+ OK := False;
+ else
+ OK := True;
+ Set_Restriction_No_Specification_Of_Aspect (Asp_Id);
+ end if;
+ end Set_NSA;
+
+ -------------
+ -- Set_NUA --
+ -------------
+
+ procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is
+ begin
+ if Is_Attribute_Name (Attr) then
+ OK := True;
+ Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr));
+ else
+ OK := False;
+ end if;
+ end Set_NUA;
+
+ -------------
+ -- Set_NUP --
+ -------------
+
+ procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is
+ begin
+ if Is_Pragma_Name (Prag) then
+ OK := True;
+ Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag));
+ else
+ OK := False;
+ end if;
+ end Set_NUP;
+
--------------------------
-- Unchecked_Convert_To --
--------------------------
Index: tbuild.ads
===================================================================
--- tbuild.ads (revision 223661)
+++ tbuild.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -347,9 +347,12 @@
function Make_Id (Str : Text_Buffer) return Node_Id;
function Make_SC (Pre, Sel : Node_Id) return Node_Id;
- procedure Set_RND (Unit : Node_Id);
+ procedure Set_NOD (Unit : Node_Id);
+ procedure Set_NSA (Asp : Name_Id; OK : out Boolean);
+ procedure Set_NUA (Attr : Name_Id; OK : out Boolean);
+ procedure Set_NUP (Prag : Name_Id; OK : out Boolean);
-- Subprograms for call to Get_Target_Parameters in Gnat1drv, see spec
- -- of package Targparm for full description of these three subprograms.
+ -- of package Targparm for full description of these four subprograms.
-- These have to be declared at the top level of a package (accessibility
-- issues), and Gnat1drv is a procedure, so they can't go there.
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb (revision 223672)
+++ gnat1drv.adb (working copy)
@@ -954,13 +954,20 @@
System_Source_File_Index := S;
end if;
+ -- Call to get target parameters. Note that the actual interface
+ -- routines in Tbuild here. They can't be in this procedure
+ -- because of accessibility issues.
+
Targparm.Get_Target_Parameters
(System_Text => Source_Text (S),
Source_First => Source_First (S),
Source_Last => Source_Last (S),
Make_Id => Tbuild.Make_Id'Access,
Make_SC => Tbuild.Make_SC'Access,
- Set_RND => Tbuild.Set_RND'Access);
+ Set_NOD => Tbuild.Set_NOD'Access,
+ Set_NSA => Tbuild.Set_NSA'Access,
+ Set_NUA => Tbuild.Set_NUA'Access,
+ Set_NUP => Tbuild.Set_NUP'Access);
-- Acquire configuration pragma information from Targparm
Index: targparm.adb
===================================================================
--- targparm.adb (revision 223661)
+++ targparm.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2015, 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- --
@@ -154,7 +154,10 @@
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null)
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null)
is
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
@@ -181,7 +184,10 @@
Source_Last => Hi,
Make_Id => Make_Id,
Make_SC => Make_SC,
- Set_RND => Set_RND);
+ Set_NOD => Set_NOD,
+ Set_NSA => Set_NSA,
+ Set_NUA => Set_NUA,
+ Set_NUP => Set_NUP);
end Get_Target_Parameters;
-- Version where caller supplies system.ads text
@@ -192,7 +198,10 @@
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null)
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null)
is
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
@@ -203,6 +212,48 @@
Result : Boolean;
-- Records boolean from system line
+ OK : Boolean;
+ -- Status result from Set_NUP/NSA/NUA call
+
+ PR_Start : Source_Ptr;
+ -- Pointer to ( following pragma Restrictions
+
+ procedure Collect_Name;
+ -- Scan a name starting at System_Text (P), and put Name in Name_Buffer,
+ -- with Name_Len being length, folded to lower case. On return P points
+ -- just past the last character (which should be a right paren).
+
+ ------------------
+ -- Collect_Name --
+ ------------------
+
+ procedure Collect_Name is
+ begin
+ Name_Len := 0;
+ loop
+ if System_Text (P) in 'a' .. 'z'
+ or else
+ System_Text (P) = '_'
+ or else
+ System_Text (P) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 1) := System_Text (P);
+
+ elsif System_Text (P) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 1) :=
+ Character'Val (Character'Pos (System_Text (P)) + 32);
+
+ else
+ exit;
+ end if;
+
+ P := P + 1;
+ Name_Len := Name_Len + 1;
+ end loop;
+ end Collect_Name;
+
+ -- Start of processing for Get_Target_Parameters
+
begin
if Parameters_Obtained then
return;
@@ -261,7 +312,10 @@
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
+ PR_Start := P - 1;
+ -- Boolean restrictions
+
Rloop : for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
@@ -285,7 +339,9 @@
null;
end loop Rloop;
- Ploop : for K in All_Parameter_Restrictions loop
+ -- Restrictions taking integer parameter
+
+ Ploop : for K in Integer_Parameter_Restrictions loop
declare
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
@@ -400,23 +456,119 @@
P := P + 1;
end loop;
- Set_RND (Unit);
+ Set_NOD (Unit);
goto Line_Loop_Continue;
end;
+
+ -- No_Specification_Of_Aspect case
+
+ elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => "
+ then
+ P := P + 30;
+
+ -- Skip this processing (and simply ignore the pragma), if
+ -- caller did not supply the subprogram we need to process
+ -- such lines.
+
+ if Set_NSA = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Specification_Of_Aspect =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NSA (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
+
+ -- No_Use_Of_Attribute case
+
+ elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then
+ P := P + 23;
+
+ -- Skip this processing (and simply ignore No_Use_Of_Attribute
+ -- lines) if caller did not supply the subprogram we need to
+ -- process such lines.
+
+ if Set_NUA = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Use_Of_Attribute =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NUA (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
+
+ -- No_Use_Of_Pragma case
+
+ elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then
+ P := P + 20;
+
+ -- Skip this processing (and simply ignore No_Use_Of_Pragma
+ -- lines) if caller did not supply the subprogram we need to
+ -- process such lines.
+
+ if Set_NUP = null then
+ goto Line_Loop_Continue;
+ end if;
+
+ -- We have scanned
+ -- "pragma Restrictions (No_Use_Of_Pragma =>"
+
+ Collect_Name;
+
+ if System_Text (P) /= ')' then
+ goto Bad_Restrictions_Pragma;
+
+ else
+ Set_NUP (Name_Find, OK);
+
+ if OK then
+ goto Line_Loop_Continue;
+ else
+ goto Bad_Restrictions_Pragma;
+ end if;
+ end if;
end if;
-- Here if unrecognizable restrictions pragma form
+ <<Bad_Restrictions_Pragma>>
+
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("unrecognized or incorrect restrictions pragma: ");
- while System_Text (P) /= ')'
- and then
- System_Text (P) /= ASCII.LF
+ P := PR_Start;
loop
+ exit when System_Text (P) = ASCII.LF;
Write_Char (System_Text (P));
+ exit when System_Text (P) = ')';
P := P + 1;
end loop;
Index: targparm.ads
===================================================================
--- targparm.ads (revision 223661)
+++ targparm.ads (working copy)
@@ -615,28 +615,53 @@
-- selected component with Sloc value System_Location and given Prefix
-- (Pre) and Selector (Sel) values.
- type Set_RND_Type is access procedure (Unit : Node_Id);
+ type Set_NOD_Type is access procedure (Unit : Node_Id);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Dependence for the given unit (identifier or selected component).
+ type Set_NSA_Type is access procedure (Asp : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Specificaztion_Of_Aspect. Asp is the pragma name. OK is set True
+ -- if this is an OK aspect name, and False if it is not an aspect name.
+
+ type Set_NUA_Type is access procedure (Attr : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Use_Of_Attribute. Prag is the attribute name. OK is set True if
+ -- this is an OK attribute name, and False if it is not an attribute name.
+
+ type Set_NUP_Type is access procedure (Prag : Name_Id; OK : out Boolean);
+ -- Parameter type for Get_Target_Parameters that records a Restriction
+ -- No_Use_Of_Pragma. Prag is the pragma name. OK is set True if this is
+ -- an OK pragma name, and False if it is not a recognized pragma name.
+
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null);
- -- Called at the start of execution to obtain target parameters from
- -- the source of package System. The parameters provide the source
- -- text to be scanned (in System_Text (Source_First .. Source_Last)).
- -- if the three subprograms are left at their default value of null,
- -- Get_Target_Parameters will ignore pragma Restrictions No_Dependence
- -- lines, otherwise it will use these three subprograms to record them.
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null);
+ -- Called at the start of execution to obtain target parameters from the
+ -- source of package System. The parameters provide the source text to be
+ -- scanned (in System_Text (Source_First .. Source_Last)). if the three
+ -- subprograms Make_Id, Make_SC, and Set_NOD are left at their default
+ -- value of null, Get_Target_Parameters will ignore pragma Restrictions
+ -- No_Dependence lines, otherwise it will use these three subprograms to
+ -- record them. Similarly if Set_NUP is left at its default value of null,
+ -- then any occurrences of pragma Restrictions (No_Use_Of_Pragma => XXX)
+ -- will be ignored, otherwise it will use this procedure to record the
+ -- pragma. Similarly for the NSA and NUA cases.
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
- Set_RND : Set_RND_Type := null);
+ Set_NOD : Set_NOD_Type := null;
+ Set_NSA : Set_NSA_Type := null;
+ Set_NUA : Set_NUA_Type := null;
+ Set_NUP : Set_NUP_Type := null);
-- This version reads in system.ads using Osint. The idea is that the
-- caller uses the first version if they have to read system.ads anyway
-- (e.g. the compiler) and uses this simpler interface if system.ads is
Index: restrict.adb
===================================================================
--- restrict.adb (revision 223661)
+++ restrict.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
@@ -35,7 +34,6 @@
with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Snames; use Snames;
with Stand; use Stand;
with Uname; use Uname;
@@ -111,6 +109,8 @@
No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
(others => No_Location);
+ -- Source location of pragma No_Use_Of_Pragma for given pragma, a value
+ -- of Sysstem_Location indicates occurrence in system.ads.
No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
(others => False);
@@ -1569,6 +1569,13 @@
No_Specification_Of_Aspect_Set := True;
end Set_Restriction_No_Specification_Of_Aspect;
+ procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
+ begin
+ No_Specification_Of_Aspects (A_Id) := System_Location;
+ No_Specification_Of_Aspect_Warning (A_Id) := False;
+ No_Specification_Of_Aspect_Set := True;
+ end Set_Restriction_No_Specification_Of_Aspect;
+
-----------------------------------------
-- Set_Restriction_No_Use_Of_Attribute --
-----------------------------------------
@@ -1588,6 +1595,13 @@
end if;
end Set_Restriction_No_Use_Of_Attribute;
+ procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
+ begin
+ No_Use_Of_Attribute_Set := True;
+ No_Use_Of_Attribute (A_Id) := System_Location;
+ No_Use_Of_Attribute_Warning (A_Id) := False;
+ end Set_Restriction_No_Use_Of_Attribute;
+
--------------------------------------
-- Set_Restriction_No_Use_Of_Pragma --
--------------------------------------
@@ -1607,6 +1621,13 @@
end if;
end Set_Restriction_No_Use_Of_Pragma;
+ procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
+ begin
+ No_Use_Of_Pragma_Set := True;
+ No_Use_Of_Pragma_Warning (A_Id) := False;
+ No_Use_Of_Pragma (A_Id) := System_Location;
+ end Set_Restriction_No_Use_Of_Pragma;
+
--------------------------------
-- Check_SPARK_05_Restriction --
--------------------------------
Index: restrict.ads
===================================================================
--- restrict.ads (revision 223661)
+++ restrict.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -25,11 +25,13 @@
-- This package deals with the implementation of the Restrictions pragma
-with Namet; use Namet;
-with Rident; use Rident;
+with Aspects; use Aspects;
+with Namet; use Namet;
+with Rident; use Rident;
+with Snames; use Snames;
with Table;
-with Types; use Types;
-with Uintp; use Uintp;
+with Types; use Types;
+with Uintp; use Uintp;
package Restrict is
@@ -463,6 +465,9 @@
-- case of a Restriction_Warnings pragma specifying this restriction and
-- False for a Restrictions pragma specifying this restriction.
+ procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id);
+ -- Version used by Get_Target_Parameters (via Tbuild)
+
procedure Set_Restriction_No_Use_Of_Attribute
(N : Node_Id;
Warning : Boolean);
@@ -470,6 +475,9 @@
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
+ procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id);
+ -- Version used by Get_Target_Parameters (via Tbuild)
+
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
Warn : Boolean;
@@ -488,6 +496,9 @@
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id.
+ procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id);
+ -- Version used in call from Get_Target_Parameters (via Tbuild).
+
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests if tasking operations are allowed by the current restrictions
Index: s-rident.ads
===================================================================
--- s-rident.ads (revision 223661)
+++ s-rident.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -255,6 +255,11 @@
No_Specification_Of_Aspect .. Max_Storage_At_Blocking;
-- All restrictions that take a parameter
+ subtype Integer_Parameter_Restrictions is
+ Restriction_Id range
+ Max_Protected_Entries .. Max_Storage_At_Blocking;
+ -- All restrictions taking an integer parameter
+
subtype Checked_Parameter_Restrictions is
All_Parameter_Restrictions range
Max_Protected_Entries .. Max_Entry_Queue_Length;
