-- --
-- 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- --
-- Local functions, used only in this chapter
procedure Scan_Pragma_Argument_Association
- (Identifier_Seen : in out Boolean;
- Association : out Node_Id);
- -- Scans out a pragma argument association. Identifier_Seen is true on
- -- entry if a previous association had an identifier, and gets set True if
- -- the scanned association has an identifier (this is used to check the
+ (Identifier_Seen : in out Boolean;
+ Association : out Node_Id;
+ Reserved_Words_OK : Boolean := False);
+ -- Scans out a pragma argument association. Identifier_Seen is True on
+ -- entry if a previous association had an identifier, and gets set True
+ -- if the scanned association has an identifier (this is used to check the
-- rule that no associations without identifiers can follow an association
- -- which has an identifier). The result is returned in Association.
+ -- which has an identifier). The result is returned in Association. Flag
+ -- For_Pragma_Restrictions should be set when arguments are being parsed
+ -- for pragma Restrictions.
--
-- Note: We allow attribute forms Pre'Class, Post'Class, Invariant'Class,
-- Type_Invariant'Class in place of a pragma argument identifier. Rather
if Ada_Version >= Ada_2005
and then Token = Tok_Interface
then
- Prag_Name := Name_Interface;
- Ident_Node := Make_Identifier (Token_Ptr, Name_Interface);
+ Prag_Name := Name_Interface;
+ Ident_Node := Make_Identifier (Token_Ptr, Name_Interface);
Scan; -- past INTERFACE
else
Ident_Node := P_Identifier;
loop
Arg_Count := Arg_Count + 1;
- Scan_Pragma_Argument_Association (Identifier_Seen, Assoc_Node);
+
+ Scan_Pragma_Argument_Association
+ (Identifier_Seen => Identifier_Seen,
+ Association => Assoc_Node,
+ Reserved_Words_OK =>
+ Nam_In (Prag_Name, Name_Restriction_Warnings,
+ Name_Restrictions));
if Arg_Count = 2
and then (Interface_Check_Required or else Import_Check_Required)
-- Error recovery: cannot raise Error_Resync
procedure Scan_Pragma_Argument_Association
- (Identifier_Seen : in out Boolean;
- Association : out Node_Id)
+ (Identifier_Seen : in out Boolean;
+ Association : out Node_Id;
+ Reserved_Words_OK : Boolean := False)
is
- Scan_State : Saved_Scan_State;
+ function P_Expression_Or_Reserved_Word return Node_Id;
+ -- Parse an expression or if the token denotes one of the following
+ -- reserved words, construct an identifier with proper Chars field.
+ -- Access
+ -- Delta
+ -- Digits
+ -- Mod
+ -- Range
+
+ -----------------------------------
+ -- P_Expression_Or_Reserved_Word --
+ -----------------------------------
+
+ function P_Expression_Or_Reserved_Word return Node_Id is
+ Word : Node_Id;
+ Word_Id : Name_Id;
+
+ begin
+ Word_Id := No_Name;
+
+ if Token = Tok_Access then
+ Word_Id := Name_Access;
+ Scan; -- past ACCESS
+
+ elsif Token = Tok_Delta then
+ Word_Id := Name_Delta;
+ Scan; -- past DELTA
+
+ elsif Token = Tok_Digits then
+ Word_Id := Name_Digits;
+ Scan; -- past DIGITS
+
+ elsif Token = Tok_Mod then
+ Word_Id := Name_Mod;
+ Scan; -- past MOD
+
+ elsif Token = Tok_Range then
+ Word_Id := Name_Range;
+ Scan; -- post RANGE
+ end if;
+
+ if Word_Id = No_Name then
+ return P_Expression;
+ else
+ Word := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Word, Word_Id);
+ return Word;
+ end if;
+ end P_Expression_Or_Reserved_Word;
+
+ -- Local variables
+
+ Expression_Node : Node_Id;
Identifier_Node : Node_Id;
- Id_Present : Boolean;
+ Identifier_OK : Boolean;
+ Scan_State : Saved_Scan_State;
+
+ -- Start of processing for Scan_Pragma_Argument_Association
begin
Association := New_Node (N_Pragma_Argument_Association, Token_Ptr);
Set_Chars (Association, No_Name);
- Id_Present := False;
+ Identifier_OK := False;
-- Argument starts with identifier
if Token = Tok_Arrow then
Scan; -- past arrow
- Id_Present := True;
+ Identifier_OK := True;
-- Case of one of the special aspect forms
-- Here we have scanned identifier'Class =>
else
- Id_Present := True;
+ Identifier_OK := True;
Scan; -- past arrow
case Chars (Identifier_Node) is
-- Identifier was present
- if Id_Present then
+ if Identifier_OK then
Set_Chars (Association, Chars (Identifier_Node));
Identifier_Seen := True;
-- message in Relaxed_RM_Semantics mode to help legacy code using e.g.
-- codepeer.
- if Identifier_Seen and not Id_Present and not Relaxed_RM_Semantics then
+ if Identifier_Seen
+ and not Identifier_OK
+ and not Relaxed_RM_Semantics
+ then
Error_Msg_SC ("|pragma argument identifier required here");
Error_Msg_SC ("\since previous argument had identifier (RM 2.8(4))");
end if;
- if Id_Present then
- Set_Expression (Association, P_Expression);
+ if Identifier_OK then
+
+ -- Certain pragmas such as Restriction_Warninds and Restrictions
+ -- allow reserved words to appear as expressions when checking for
+ -- prohibited uses of attributes.
+
+ if Reserved_Words_OK
+ and then Chars (Identifier_Node) = Name_No_Use_Of_Attribute
+ then
+ Expression_Node := P_Expression_Or_Reserved_Word;
+ else
+ Expression_Node := P_Expression;
+ end if;
else
- Set_Expression (Association, P_Expression_If_OK);
+ Expression_Node := P_Expression_If_OK;
end if;
+
+ Set_Expression (Association, Expression_Node);
end Scan_Pragma_Argument_Association;
end Ch2;
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
+ -----------------------------------------
+ -- Check_Implicit_Dynamic_Code_Allowed --
+ -----------------------------------------
+
+ procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
+ begin
+ Check_Restriction (No_Implicit_Dynamic_Code, N);
+ end Check_Implicit_Dynamic_Code_Allowed;
+
--------------------------------
-- Check_No_Implicit_Aliasing --
--------------------------------
Check_Restriction (No_Implicit_Aliasing, Obj);
end Check_No_Implicit_Aliasing;
- -----------------------------------------
- -- Check_Implicit_Dynamic_Code_Allowed --
- -----------------------------------------
-
- procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
- begin
- Check_Restriction (No_Implicit_Dynamic_Code, N);
- end Check_Implicit_Dynamic_Code_Allowed;
-
----------------------------------
-- Check_No_Implicit_Heap_Alloc --
----------------------------------
--------------------------------------------
procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
- Id : constant Name_Id := Chars (N);
- A_Id : constant Attribute_Id := Get_Attribute_Id (Id);
+ Attr_Id : Attribute_Id;
+ Attr_Nam : Name_Id;
begin
- -- Ignore call if node N is not in the main source unit, since we only
- -- give messages for the main unit. This avoids giving messages for
- -- aspects that are specified in withed units.
+ -- Nothing to do if the attribute is not in the main source unit, since
+ -- we only give messages for the main unit. This avoids giving messages
+ -- for attributes that are specified in withed units.
if not In_Extended_Main_Source_Unit (N) then
return;
- end if;
- -- If nothing set, nothing to check
+ -- Nothing to do if not checking No_Use_Of_Attribute
+
+ elsif not No_Use_Of_Attribute_Set then
+ return;
+
+ -- Do not consider internally generated attributes because this leads to
+ -- bizarre errors.
- if not No_Use_Of_Attribute_Set then
+ elsif not Comes_From_Source (N) then
return;
end if;
- Error_Msg_Sloc := No_Use_Of_Attribute (A_Id);
+ if Nkind (N) = N_Attribute_Definition_Clause then
+ Attr_Nam := Chars (N);
+ else
+ pragma Assert (Nkind (N) = N_Attribute_Reference);
+ Attr_Nam := Attribute_Name (N);
+ end if;
+
+ Attr_Id := Get_Attribute_Id (Attr_Nam);
+ Error_Msg_Sloc := No_Use_Of_Attribute (Attr_Id);
if Error_Msg_Sloc /= No_Location then
- Error_Msg_Node_1 := N;
- Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id);
+ Error_Msg_Name_1 := Attr_Nam;
+ Error_Msg_Warn := No_Use_Of_Attribute_Warning (Attr_Id);
Error_Msg_N
- ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N);
+ ("<*<violation of restriction `No_Use_Of_Attribute '='> %` #", N);
end if;
end Check_Restriction_No_Use_Of_Attribute;
return;
end if;
- -- Restriction is only recognized within a configuration
- -- pragma file, or within a unit of the main extended
- -- program. Note: the test for Main_Unit is needed to
- -- properly include the case of configuration pragma files.
+ -- Restriction is only recognized within a configuration pragma file,
+ -- or within a unit of the main extended program. Note: the test for
+ -- Main_Unit is needed to properly include the case of configuration
+ -- pragma files.
if Current_Sem_Unit /= Main_Unit
and then not In_Extended_Main_Source_Unit (N)
P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
begin
- -- Ignore call if node N is not in the main source unit, since we only
- -- give messages for the main unit. This avoids giving messages for
- -- aspects that are specified in withed units.
+ -- Nothing to do if the pragma is not in the main source unit, since we
+ -- only give messages for the main unit. This avoids giving messages for
+ -- pragmas that are specified in withed units.
if not In_Extended_Main_Source_Unit (N) then
return;
- end if;
- -- If nothing set, nothing to check
+ -- Nothing to do if not checking No_Use_Of_Pragma
+
+ elsif not No_Use_Of_Pragma_Set then
+ return;
+
+ -- Do not consider internally generated pragmas because this leads to
+ -- bizarre errors.
- if not No_Use_Of_Pragma_Set then
+ elsif not Comes_From_Source (N) then
return;
end if;
Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
if Error_Msg_Sloc /= No_Location then
- Error_Msg_Node_1 := Id;
Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
Error_Msg_N
- ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id);
+ ("<*<violation of restriction `No_Use_Of_Pragma '='> &` #", Id);
end if;
end Check_Restriction_No_Use_Of_Pragma;
+ --------------------------------
+ -- Check_SPARK_05_Restriction --
+ --------------------------------
+
+ procedure Check_SPARK_05_Restriction
+ (Msg : String;
+ N : Node_Id;
+ Force : Boolean := False)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+ Onode : constant Node_Id := Original_Node (N);
+
+ begin
+ -- Output message if Force set
+
+ if Force
+
+ -- Or if this node comes from source
+
+ or else Comes_From_Source (N)
+
+ -- Or if this is a range node which rewrites a range attribute and
+ -- the range attribute comes from source.
+
+ or else (Nkind (N) = N_Range
+ and then Nkind (Onode) = N_Attribute_Reference
+ and then Attribute_Name (Onode) = Name_Range
+ and then Comes_From_Source (Onode))
+
+ -- Or this is an expression that does not come from source, which is
+ -- a rewriting of an expression that does come from source.
+
+ or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
+ 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_05_Restriction;
+
+ procedure Check_SPARK_05_Restriction
+ (Msg1 : String;
+ 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_05_Restriction;
+
--------------------------------------
-- Check_Wide_Character_Restriction --
--------------------------------------
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
- Warn : Boolean;
+ Warning : Boolean;
Profile : Profile_Name := No_Profile)
is
Nam : Node_Id;
-- Error has precedence over warning
- if not Warn then
+ if not Warning then
No_Use_Of_Entity.Table (J).Warn := False;
end if;
-- Entry is not currently in table
- No_Use_Of_Entity.Append ((Entity, Warn, Profile));
+ No_Use_Of_Entity.Append ((Entity, Warning, Profile));
-- Now we need to find the direct name and set Boolean2 flag
A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
begin
- No_Specification_Of_Aspects (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Specification_Of_Aspect_Warning (A_Id) := False;
- end if;
-
No_Specification_Of_Aspect_Set := True;
+ No_Specification_Of_Aspects (A_Id) := Sloc (N);
+ No_Specification_Of_Aspect_Warning (A_Id) := Warning;
end Set_Restriction_No_Specification_Of_Aspect;
procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
begin
No_Use_Of_Attribute_Set := True;
No_Use_Of_Attribute (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Use_Of_Attribute_Warning (A_Id) := False;
- end if;
+ No_Use_Of_Attribute_Warning (A_Id) := Warning;
end Set_Restriction_No_Use_Of_Attribute;
procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
begin
No_Use_Of_Pragma_Set := True;
No_Use_Of_Pragma (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Use_Of_Pragma_Warning (A_Id) := False;
- end if;
+ No_Use_Of_Pragma_Warning (A_Id) := Warning;
end Set_Restriction_No_Use_Of_Pragma;
procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
No_Use_Of_Pragma_Warning (A_Id) := False;
end Set_Restriction_No_Use_Of_Pragma;
- --------------------------------
- -- Check_SPARK_05_Restriction --
- --------------------------------
-
- procedure Check_SPARK_05_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
- Onode : constant Node_Id := Original_Node (N);
-
- begin
- -- Output message if Force set
-
- if Force
-
- -- Or if this node comes from source
-
- or else Comes_From_Source (N)
-
- -- Or if this is a range node which rewrites a range attribute and
- -- the range attribute comes from source.
-
- or else (Nkind (N) = N_Range
- and then Nkind (Onode) = N_Attribute_Reference
- and then Attribute_Name (Onode) = Name_Range
- and then Comes_From_Source (Onode))
-
- -- Or this is an expression that does not come from source, which is
- -- a rewriting of an expression that does come from source.
-
- or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
- 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_05_Restriction;
-
- procedure Check_SPARK_05_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_05_Restriction;
-
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
projects / gcc.git / commitdiff