===================================================================
@@ -688,6 +688,42 @@
-- of the printout. If Withs is True, we print out units with'ed by this
-- unit (not counting limited withs).
+ ---------------------------------------------------------------
+ -- Special Handling for Restriction_Set (No_Dependence) Case --
+ ---------------------------------------------------------------
+
+ -- If we have a Restriction_Set attribute for No_Dependence => unit,
+ -- and the unit is not given in a No_Dependence restriction that we
+ -- can see, the attribute will return False.
+
+ -- We have to ensure in this case that the binder will reject any attempt
+ -- to set a No_Dependence restriction in some other unit in the partition.
+
+ -- If the unit is in the semantic closure, then of course it is properly
+ -- WITH'ed by someone, and the binder will do this job automatically as
+ -- part of its normal processing.
+
+ -- But if the unit is not in the semantic closure, we must make sure the
+ -- binder knows about it. The use of the Restriction_Set attribute giving
+ -- a result of False does not mean of itself that we have to include the
+ -- unit in the partition. So what we do is to generate a with (W) line in
+ -- the ali file (with no file name information), but no corresponding D
+ -- (dependency) line. This is recognized by the binder as meaning "Don't
+ -- let anyone specify No_Dependence for this unit, but you don't have to
+ -- include it if there is no real W line for the unit".
+
+ -- The following table keeps track of relevant units. It is used in the
+ -- Lib.Writ circuit for outputting With lines to output the special with
+ -- line with RA if the unit is not in the semantic closure.
+
+ package Restriction_Set_Dependences is new Table.Table (
+ Table_Component_Type => Unit_Name_Type,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Restriction_Attribute_Dependences");
+
private
pragma Inline (Cunit);
pragma Inline (Cunit_Entity);
===================================================================
@@ -343,6 +343,8 @@
* Attribute Passed_By_Reference::
* Attribute Pool_Address::
* Attribute Range_Length::
+* Attribute Ref::
+* Attribute Restriction_Set::
* Attribute Result::
* Attribute Safe_Emax::
* Attribute Safe_Large::
@@ -7645,6 +7647,7 @@
* Attribute Pool_Address::
* Attribute Range_Length::
* Attribute Ref::
+* Attribute Restriction_Set::
* Attribute Result::
* Attribute Safe_Emax::
* Attribute Safe_Large::
@@ -8332,12 +8335,76 @@
@unnumberedsec Attribute Ref
@findex Ref
@noindent
-The @code{System.Address'Ref}
-(@code{System.Address} is the only permissible prefix)
-denotes a function identical to
-@code{System.Storage_Elements.To_Address} except that
-it is a static attribute. See @ref{Attribute To_Address} for more details.
+
+@node Attribute Restriction_Set
+@unnumberedsec Attribute Restriction_Set
+@findex Restriction_Set
+@cindex Restrictions
+@noindent
+This attribute allows compile time testing of restrictions that
+are currently in effect. It is primarily intended for specializing
+code in the run-time based on restrictions that are active (e.g.
+don't need to save fpt registers if restriction No_Floating_Point
+is known to be in effect), but can be used anywhere.
+
+There are two forms:
+
+@smallexample @c ada
+System'Restriction_Set (partition_boolean_restriction_NAME)
+System'Restriction_Set (No_Dependence => library_unit_NAME);
+@end smallexample
+
+@noindent
+In the case of the first form, the only restriction names
+allowed are parameterless restrictions that are checked
+for consistency at bind time. For a complete list see the
+subtype @code{System.Rident.Partition_Boolean_Restrictions}.
+
+The result returned is True if the restriction is known to
+be in effect, and False if the restriction is known not to
+be in effect. An important guarantee is that the value of
+a Restriction_Set attribute is known to be consistent throughout
+all the code of a partition.
+
+This is trivially achieved if the entire partition is compiled
+with a consistent set of restriction pragmas. However, the
+compilation model does not require this. It is possible to
+compile one set of units with one set of pragmas, and another
+set of units with another set of pragmas. It is even possible
+to compile a spec with one set of pragmas, and then WITH the
+same spec with a different set of pragmas. Inconsistencies
+in the actual use of the restriction are checked at bind time.
+
+In order to achieve the guarantee of consistency for the
+Restriction_Set pragma, we consider that a use of the pragma
+that yields False is equivalent to a violation of the
+restriction.
+
+So for example if you write
+
+@smallexample @c ada
+if System'Restriction_Set (No_Floating_Point) then
+ ...
+else
+ ...
+end if;
+@end smallexample
+
+@noindent
+And the result is False, so that the else branch is executed,
+you can assume that this restriction is not set for any unit
+in the partition. This is checked by considering this use of
+the restriction pragma to be a violation of the restriction
+No_Floating_Point. This means that no other unit can attempt
+to set this restriction (if some unit does attempt to set it,
+the binder will refuse to bind the partition).
+
+Technical note: The restriction name and the unit name are
+intepreted entirely syntactically, as in the corresponding
+Restrictions pragma, they are not analyzed semantically,
+so they do not have a type.
+
@node Attribute Result
@unnumberedsec Attribute Result
@findex Result
===================================================================
@@ -6500,6 +6500,7 @@
Attribute_Modulus |
Attribute_Partition_ID |
Attribute_Range |
+ Attribute_Restriction_Set |
Attribute_Safe_Emax |
Attribute_Safe_First |
Attribute_Safe_Large |
===================================================================
@@ -1516,14 +1516,14 @@
-- in rtsfind to indicate implicit dependencies on predefined units. Used
-- to prevent multiple with_clauses for the same unit in a given context.
-- A postorder traversal of the tree whose nodes are units and whose
- -- links are with_clauses defines the order in which Inspector must
+ -- links are with_clauses defines the order in which CodePeer must
-- examine a compiled unit and its full context. This ordering ensures
-- that any subprogram call is examined after the subprogram declaration
-- has been seen.
-- Next_Named_Actual (Node4-Sem)
- -- Present in parameter association node. Set during semantic analysis to
- -- point to the next named parameter, where parameters are ordered by
+ -- Present in parameter association nodes. Set during semantic analysis
+ -- to point to the next named parameter, where parameters are ordered by
-- declaration order (as opposed to the actual order in the call, which
-- may be different due to named associations). Not that this field
-- points to the explicit actual parameter itself, not to the
===================================================================
@@ -882,6 +882,38 @@
Write_Info_EOL;
end loop;
+
+ -- Finally generate the special lines for cases of Restriction_Set
+ -- with No_Dependence and no restriction present.
+
+ declare
+ Unam : Unit_Name_Type;
+
+ begin
+ for J in Restriction_Set_Dependences.First ..
+ Restriction_Set_Dependences.Last
+ loop
+ Unam := Restriction_Set_Dependences.Table (J);
+
+ -- Don't need an entry if already in the unit table
+
+ for U in 0 .. Last_Unit loop
+ if Unit_Name (U) = Unam then
+ goto Continue;
+ end if;
+ end loop;
+
+ -- Otherwise generate the entry
+
+ Write_Info_Initiate ('W');
+ Write_Info_Char (' ');
+ Write_Info_Name (Unam);
+ Write_Info_EOL;
+
+ <<Continue>>
+ null;
+ end loop;
+ end;
end Write_With_Lines;
-- Start of processing for Write_ALI
===================================================================
@@ -402,7 +402,9 @@
-- No restriction pragma is present for the named boolean restriction.
-- However, the compiler did detect one or more violations of this
- -- restriction, which may require a binder consistency check.
+ -- restriction, which may require a binder consistency check. Note that
+ -- one case of a violation is the use of a Restriction_Set attribute for
+ -- the restriction that yielded False.
-- For the case of restrictions that take a parameter, we need both the
-- information from pragma if present, and the actual information about
@@ -618,9 +620,9 @@
-- Following each U line, is a series of lines of the form
-- W unit-name [source-name lib-name] [E] [EA] [ED] [AD]
- -- or
+ -- or
-- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD]
- -- or
+ -- or
-- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD]
--
-- One W line is present for each unit that is mentioned in an explicit
@@ -655,6 +657,14 @@
-- The parameter source-name and lib-name are omitted for the case of a
-- generic unit compiled with earlier versions of GNAT which did not
-- generate object or ali files for generics.
+ --
+ -- The parameter source-name and lib-name are also omitted for the W
+ -- lines that result from use of a Restriction_Set attribute which gets
+ -- a result of False from a No_Dependence check, in the case where the
+ -- unit is not in the semantic closure. In such a case, the bare W
+ -- line is generated, but no D (dependency) line. This will make the
+ -- binder do the consistency check, but not include the unit in the
+ -- partition closure (unless it is properly With'ed somewhere).
-- -----------------------
-- -- L Linker_Options --
===================================================================
@@ -6990,31 +6990,6 @@
Expr : Node_Id;
Val : Uint;
- procedure Check_Unit_Name (N : Node_Id);
- -- Checks unit name parameter for No_Dependence. Returns if it has
- -- an appropriate form, otherwise raises pragma argument error.
-
- ---------------------
- -- Check_Unit_Name --
- ---------------------
-
- procedure Check_Unit_Name (N : Node_Id) is
- begin
- if Nkind (N) = N_Selected_Component then
- Check_Unit_Name (Prefix (N));
- Check_Unit_Name (Selector_Name (N));
-
- elsif Nkind (N) = N_Identifier then
- return;
-
- else
- Error_Pragma_Arg
- ("wrong form for unit name for No_Dependence", N);
- end if;
- end Check_Unit_Name;
-
- -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
-
begin
-- Ignore all Restrictions pragmas in CodePeer mode
@@ -7174,7 +7149,9 @@
-- already made the necessary entry in the No_Dependence table.
elsif Id = Name_No_Dependence then
- Check_Unit_Name (Expr);
+ if not OK_No_Dependence_Unit_Name (Expr) then
+ raise Pragma_Exit;
+ end if;
-- Case of No_Specification_Of_Aspect => Identifier.
===================================================================
@@ -82,7 +82,7 @@
-- A unit retrieved through rtsfind may end up in the context of several
-- other units, in addition to the main unit. These additional with_clauses
- -- are needed to generate a proper traversal order for Inspector. To
+ -- are needed to generate a proper traversal order for CodePeer. To
-- minimize somewhat the redundancy created by numerous calls to rtsfind
-- from different units, we keep track of the list of implicit with_clauses
-- already created for the current loaded unit.
@@ -123,7 +123,7 @@
-- with_clauses to the extended main unit if needed, and also to whatever
-- unit needs them, which is not necessarily the main unit. The former
-- ensures that the object is correctly loaded by the binder. The latter
- -- is necessary for SofCheck Inspector.
+ -- is necessary for CodePeer.
-- The field First_Implicit_With in the unit table record are used to
-- avoid creating duplicate with_clauses.
@@ -827,10 +827,9 @@
-- We do not need to generate a with_clause for a call issued from
-- RTE_Component_Available. However, for CodePeer, we need these
-- additional with's, because for a sequence like "if RTE_Available (X)
- -- then ... RTE (X)" the RTE call fails to create some necessary
- -- with's.
+ -- then ... RTE (X)" the RTE call fails to create some necessary with's.
- if RTE_Available_Call and then not Generate_SCIL then
+ if RTE_Available_Call and not Generate_SCIL then
return;
end if;
@@ -840,8 +839,8 @@
return;
end if;
- -- Add the with_clause, if not already in the context of the
- -- current compilation unit.
+ -- Add the with_clause, if not already in the context of the current
+ -- compilation unit.
declare
LibUnit : constant Node_Id := Unit (Cunit (U.Unum));
===================================================================
@@ -40,6 +40,7 @@
Attribute_Class => True,
Attribute_External_Tag => True,
Attribute_Img => True,
+ Attribute_Loop_Entry => True,
Attribute_Stub_Type => True,
Attribute_Version => True,
Attribute_Type_Key => True,
@@ -50,6 +51,13 @@
-- list because it may denote a slice operation (X'Img (1 .. 2)) or
-- a type conversion (X'Class (Y)).
+ -- Note: Loop_Entry is in this list because, although it can take an
+ -- optional argument (the loop name), we can't distinguish that at parse
+ -- time from the case where no loop name is given and a legitimate index
+ -- expression is present. So we parse the argument as an indexed component
+ -- and the semantic analysis sorts out this syntactic ambiguity based on
+ -- the type and form of the expression.
+
-- Note that this map designates the minimum set of attributes where a
-- construct in parentheses that is not an argument can appear right
-- after the attribute. For attributes like 'Size, we do not put them
@@ -503,29 +511,24 @@
Set_Attribute_Name (Name_Node, Attr_Name);
-- Scan attribute arguments/designator. We skip this if we know
- -- that the attribute cannot have an argument.
+ -- that the attribute cannot have an argument (see documentation
+ -- of Is_Parameterless_Attribute for further details).
if Token = Tok_Left_Paren
and then not
Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
then
- -- Attribute Loop_Entry has no effect on the name extension
- -- parsing logic, as if the attribute never existed in the
- -- source. Continue parsing the subsequent expressions or
- -- ranges.
-
- if Attr_Name = Name_Loop_Entry then
- Scan; -- past left paren
- goto Scan_Name_Extension_Left_Paren;
-
-- Attribute Update contains an array or record association
-- list which provides new values for various components or
- -- elements. The list is parsed as an aggregate.
+ -- elements. The list is parsed as an aggregate, and we get
+ -- better error handling by knowing that in the parser.
- elsif Attr_Name = Name_Update then
+ if Attr_Name = Name_Update then
Set_Expressions (Name_Node, New_List);
Append (P_Aggregate, Expressions (Name_Node));
+ -- All other cases of parsing attribute arguments
+
else
Set_Expressions (Name_Node, New_List);
Scan; -- past left paren
@@ -533,13 +536,41 @@
loop
declare
Expr : constant Node_Id := P_Expression_If_OK;
+ Rnam : Node_Id;
begin
+ -- Case of => for named notation
+
if Token = Tok_Arrow then
- Error_Msg_SC
- ("named parameters not permitted for attributes");
- Scan; -- past junk arrow
+ -- Named notation allowed only for the special
+ -- case of System'Restriction_Set (No_Dependence =>
+ -- unit_NAME), in which case construct a parameter
+ -- assocation node and append to the arguments.
+
+ if Attr_Name = Name_Restriction_Set
+ and then Nkind (Expr) = N_Identifier
+ and then Chars (Expr) = Name_No_Dependence
+ then
+ Scan; -- past arrow
+ Rnam := P_Name;
+ Append_To (Expressions (Name_Node),
+ Make_Parameter_Association (Sloc (Rnam),
+ Selector_Name => Expr,
+ Explicit_Actual_Parameter => Rnam));
+ exit;
+
+ -- For all other cases named notation is illegal
+
+ else
+ Error_Msg_SC
+ ("named parameters not permitted "
+ & "for attributes");
+ Scan; -- past junk arrow
+ end if;
+
+ -- Here for normal case (not => for named parameter)
+
else
Append (Expr, Expressions (Name_Node));
exit when not Comma_Present;
===================================================================
@@ -72,6 +72,7 @@
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Uname; use Uname;
with Urealp; use Urealp;
package body Sem_Attr is
@@ -1642,9 +1643,7 @@
begin
Check_E0;
- if Nkind (P) /= N_Identifier
- or else Chars (P) /= Name_Standard
- then
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
Error_Attr ("only allowed prefix for % attribute is Standard", P);
end if;
end Check_Standard_Prefix;
@@ -1658,12 +1657,11 @@
Btyp : Entity_Id;
In_Shared_Var_Procs : Boolean;
- -- True when compiling the body of System.Shared_Storage.
- -- Shared_Var_Procs. For this runtime package (always compiled in
- -- GNAT mode), we allow stream attributes references for limited
- -- types for the case where shared passive objects are implemented
- -- using stream attributes, which is the default in GNAT's persistent
- -- storage implementation.
+ -- True when compiling System.Shared_Storage.Shared_Var_Procs body.
+ -- For this runtime package (always compiled in GNAT mode), we allow
+ -- stream attributes references for limited types for the case where
+ -- shared passive objects are implemented using stream attributes,
+ -- which is the default in GNAT's persistent storage implementation.
begin
Validate_Non_Static_Attribute_Function_Call;
@@ -2049,16 +2047,11 @@
-- some attributes for which we do not analyze the prefix, since the
-- prefix is not a normal name, or else needs special handling.
- if Aname /= Name_Elab_Body
- and then
- Aname /= Name_Elab_Spec
- and then
- Aname /= Name_Elab_Subp_Body
- and then
- Aname /= Name_UET_Address
- and then
- Aname /= Name_Enabled
- and then
+ if Aname /= Name_Elab_Body and then
+ Aname /= Name_Elab_Spec and then
+ Aname /= Name_Elab_Subp_Body and then
+ Aname /= Name_UET_Address and then
+ Aname /= Name_Enabled and then
Aname /= Name_Old
then
Analyze (P);
@@ -2122,12 +2115,18 @@
else
E1 := First (Exprs);
- Analyze (E1);
- -- Check for missing/bad expression (result of previous error)
+ -- Skip analysis for case of Restriction_Set, we do not expect
+ -- the argument to be analyzed in this case.
- if No (E1) or else Etype (E1) = Any_Type then
- raise Bad_Attribute;
+ if Aname /= Name_Restriction_Set then
+ Analyze (E1);
+
+ -- Check for missing/bad expression (result of previous error)
+
+ if No (E1) or else Etype (E1) = Any_Type then
+ raise Bad_Attribute;
+ end if;
end if;
E2 := Next (E1);
@@ -4832,6 +4831,121 @@
Resolve (E1, P_Base_Type);
Resolve (E2, P_Base_Type);
+ ---------------------
+ -- Restriction_Set --
+ ---------------------
+
+ when Attribute_Restriction_Set => Restriction_Set : declare
+ R : Restriction_Id;
+ U : Node_Id;
+ Unam : Unit_Name_Type;
+
+ procedure Set_Result (B : Boolean);
+ -- Replace restriction node by static constant False or True,
+ -- depending on the value of B.
+
+ ----------------
+ -- Set_Result --
+ ----------------
+
+ procedure Set_Result (B : Boolean) is
+ begin
+ if B then
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ end if;
+
+ Set_Is_Static_Expression (N);
+ end Set_Result;
+
+ -- Start of processing for Restriction_Set
+
+ begin
+ Check_E1;
+ Analyze (P);
+
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
+ Set_Result (False);
+ Error_Attr_P ("prefix of % attribute must be System");
+ end if;
+
+ -- No_Dependence case
+
+ if Nkind (E1) = N_Parameter_Association then
+ pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence);
+ U := Explicit_Actual_Parameter (E1);
+
+ if not OK_No_Dependence_Unit_Name (U) then
+ Set_Result (False);
+ Error_Attr;
+ end if;
+
+ -- See if there is an entry already in the table. That's the
+ -- case in which we can return True.
+
+ for J in No_Dependences.First .. No_Dependences.Last loop
+ if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
+ and then No_Dependences.Table (J).Warn = False
+ then
+ Set_Result (True);
+ return;
+ end if;
+ end loop;
+
+ -- If not in the No_Dependence table, result is False
+
+ Set_Result (False);
+
+ -- In this case, we must ensure that the binder will reject any
+ -- other unit in the partition that sets No_Dependence for this
+ -- unit. We do that by making an entry in the special table kept
+ -- for this purpose (if the entry is not there already).
+
+ Unam := Get_Spec_Name (Get_Unit_Name (U));
+
+ for J in Restriction_Set_Dependences.First ..
+ Restriction_Set_Dependences.Last
+ loop
+ if Restriction_Set_Dependences.Table (J) = Unam then
+ return;
+ end if;
+ end loop;
+
+ Restriction_Set_Dependences.Append (Unam);
+
+ -- Normal restriction case
+
+ else
+ if Nkind (E1) /= N_Identifier then
+ Set_Result (False);
+ Error_Attr ("attribute % requires restriction identifier", E1);
+
+ else
+ R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
+
+ if R = Not_A_Restriction_Id then
+ Set_Result (False);
+ Error_Msg_Node_1 := E1;
+ Error_Attr ("invalid restriction identifier &", E1);
+
+ elsif R not in Partition_Boolean_Restrictions then
+ Set_Result (False);
+ Error_Msg_Node_1 := E1;
+ Error_Attr
+ ("& is not a boolean partition-wide restriction", E1);
+ end if;
+
+ if Restriction_Active (R) then
+ Set_Result (True);
+ else
+ Check_Restriction (R, N);
+ Set_Result (False);
+ end if;
+ end if;
+ end if;
+ end Restriction_Set;
+
-----------
-- Round --
-----------
@@ -5334,9 +5448,7 @@
Check_E1;
Analyze (P);
- if Nkind (P) /= N_Identifier
- or else Chars (P) /= Name_System
- then
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
Error_Attr_P ("prefix of % attribute must be System");
end if;
@@ -8072,6 +8184,16 @@
Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static);
end Remainder;
+ -----------------
+ -- Restriction --
+ -----------------
+
+ when Attribute_Restriction_Set => Restriction_Set : declare
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ Set_Is_Static_Expression (N);
+ end Restriction_Set;
+
-----------
-- Round --
-----------
===================================================================
@@ -184,69 +184,6 @@
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
- -----------------------------
- -- Check_SPARK_Restriction --
- -----------------------------
-
- procedure Check_SPARK_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- if Force or else Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg, N);
- end if;
- end if;
- end Check_SPARK_Restriction;
-
- procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
-
- if Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg1, N);
- Error_Msg_F (Msg2, N);
- end if;
- end if;
- end Check_SPARK_Restriction;
-
--------------------------------
-- Check_No_Implicit_Aliasing --
--------------------------------
@@ -883,6 +820,27 @@
and then Restriction_Active (No_Exception_Propagation);
end No_Exception_Propagation_Active;
+ --------------------------------
+ -- OK_No_Dependence_Unit_Name --
+ --------------------------------
+
+ function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ return
+ OK_No_Dependence_Unit_Name (Prefix (N))
+ and then
+ OK_No_Dependence_Unit_Name (Selector_Name (N));
+
+ elsif Nkind (N) = N_Identifier then
+ return True;
+
+ else
+ Error_Msg_N ("wrong form for unit name for No_Dependence", N);
+ return False;
+ end if;
+ end OK_No_Dependence_Unit_Name;
+
----------------------------------
-- Process_Restriction_Synonyms --
----------------------------------
@@ -1437,6 +1395,69 @@
end if;
end Set_Restriction_No_Use_Of_Pragma;
+ -----------------------------
+ -- Check_SPARK_Restriction --
+ -----------------------------
+
+ procedure Check_SPARK_Restriction
+ (Msg : String;
+ N : Node_Id;
+ Force : Boolean := False)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+
+ begin
+ if Force or else Comes_From_Source (Original_Node (N)) then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
+ procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+
+ begin
+ pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
+
+ if Comes_From_Source (Original_Node (N)) then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg1, N);
+ Error_Msg_F (Msg2, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
===================================================================
@@ -302,6 +302,11 @@
-- identifier, and if so returns the corresponding Restriction_Id value,
-- otherwise returns Not_A_Restriction_Id.
+ function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean;
+ -- Used in checking No_Dependence argument of pragma Restrictions or
+ -- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
+ -- True if N has the proper form for a unit name, False otherwise.
+
function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
-- Determine if given location is covered by a hidden region range in the
-- SPARK hides table.
===================================================================
@@ -903,6 +903,7 @@
Name_Range : constant Name_Id := N + $;
Name_Range_Length : constant Name_Id := N + $; -- GNAT
Name_Ref : constant Name_Id := N + $; -- GNAT
+ Name_Restriction_Set : constant Name_Id := N + $; -- GNAT
Name_Result : constant Name_Id := N + $; -- GNAT
Name_Round : constant Name_Id := N + $;
Name_Safe_Emax : constant Name_Id := N + $; -- Ada 83
@@ -1519,6 +1520,7 @@
Attribute_Range,
Attribute_Range_Length,
Attribute_Ref,
+ Attribute_Restriction_Set,
Attribute_Result,
Attribute_Round,
Attribute_Safe_Emax,