+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * snames.ads-tmpl (Renamed): New name for the pragma argument.
+ * par-ch2.adb: Allow the new pragma (with analysis deferred
+ to Sem_Prag).
+ * sinfo.ads, sinfo.adb (Map_Pragma_Name, Pragma_Name_Mapped):
+ Keep a mapping from new pragma names to old names.
+ * sem_prag.adb: Check legality of pragma Rename_Pragma, and
+ implement it by calling Map_Pragma_Name.
+ * checks.adb, contracts.adb, einfo.adb, errout.adb,
+ * exp_attr.adb, exp_ch3.adb, exp_ch6.adb, exp_ch7.adb, exp_ch9.adb,
+ * exp_prag.adb, exp_util.adb, freeze.adb, frontend.adb, ghost.adb,
+ * inline.adb, lib-writ.adb, scans.adb, scans.ads, sem_attr.adb,
+ * sem_aux.adb, sem_ch10.adb, sem_ch13.adb, sem_ch6.adb, sem_ch9.adb,
+ * sem_elab.adb, sem_res.adb, sem_util.adb, sem_util.ads,
+ * sem_warn.adb: Call Pragma_Name_Mapped instead of Pragma_Name
+ as appropriate.
+
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb: Minor reformatting.
begin
Prag :=
Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Prag_Nam),
+ Chars => Prag_Nam,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Chars => Name_Check,
-- Local variables
- Prag_Nam : Name_Id;
-
- -- Start of processing for Add_Contract_Item
-
- begin
-- A contract must contain only pragmas
pragma Assert (Nkind (Prag) = N_Pragma);
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name_Mapped (Prag);
+
+ -- Start of processing for Add_Contract_Item
+ begin
-- Create a new contract when adding the first item
if No (Items) then
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam := Pragma_Name_Mapped (Prag);
if Prag_Nam = Name_Contract_Cases then
Prag := Classifications (Items);
while Present (Prag) loop
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam := Pragma_Name_Mapped (Prag);
if Prag_Nam = Name_Depends then
Depends := Prag;
Prag := Classifications (Items);
while Present (Prag) loop
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam := Pragma_Name_Mapped (Prag);
if Prag_Nam = Name_Initial_Condition then
Init_Cond := Prag;
if Present (Items) then
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Contract_Cases then
+ if Pragma_Name_Mapped (Prag) = Name_Contract_Cases then
Expand_Pragma_Contract_Cases
(CCs => Prag,
Subp_Id => Subp_Id,
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Post_Nam then
+ if Pragma_Name_Mapped (Prag) = Post_Nam then
Append_Enabled_Item
(Item => Build_Pragma_Check_Equivalent (Prag),
List => Stmts);
-- Note that non-matching pragmas are skipped
if Nkind (Decl) = N_Pragma then
- if Pragma_Name (Decl) = Post_Nam then
+ if Pragma_Name_Mapped (Decl) = Post_Nam then
Append_Enabled_Item
(Item => Build_Pragma_Check_Equivalent (Decl),
List => Stmts);
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Postcondition then
+ if Pragma_Name_Mapped (Prag) = Name_Postcondition then
Append_Enabled_Item
(Item => Build_Pragma_Check_Equivalent (Prag),
List => Stmts);
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Postcondition
+ if Pragma_Name_Mapped (Prag) = Name_Postcondition
and then Class_Present (Prag)
then
Append_Enabled_Item
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Precondition
+ if Pragma_Name_Mapped (Prag) = Name_Precondition
and then Class_Present (Prag)
then
Check_Prag :=
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Precondition then
+ if Pragma_Name_Mapped (Prag) = Name_Precondition then
Prepend_To_Decls_Or_Save (Prag);
end if;
-- Note that non-matching pragmas are skipped
if Nkind (Decl) = N_Pragma then
- if Pragma_Name (Decl) = Name_Precondition then
+ if Pragma_Name_Mapped (Decl) = Name_Precondition then
Prepend_To_Decls_Or_Save (Decl);
end if;
Ritem := First_Rep_Item (Id);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Attach_Handler
+ and then Pragma_Name_Mapped (Ritem) = Name_Attach_Handler
then
return True;
else
Ritem := First_Rep_Item (Id);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Interrupt_Handler
+ and then Pragma_Name_Mapped (Ritem) = Name_Interrupt_Handler
then
return True;
else
-- identifiers, pragmas, and pragma argument associations.
if Nkind (Node) = N_Pragma then
- Nam := Pragma_Name (Node);
+ Nam := Pragma_Name_Mapped (Node);
Loc := Sloc (Node);
-- The other cases have Chars fields
N := First_Rep_Item (Implementation_Base_Type (T));
while Present (N) loop
if Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_Stream_Convert
+ and then Pragma_Name_Mapped (N) = Name_Stream_Convert
then
-- For tagged types this pragma is not inherited, so we
-- must verify that it is defined for the given type and
-- Conversion for Priority expression
if Nam = Name_Priority then
- if Pragma_Name (Ritem) = Name_Priority
+ if Pragma_Name_Mapped (Ritem) = Name_Priority
and then not GNAT_Mode
then
Exp := Convert_To (RTE (RE_Priority), Exp);
elsif Present (Next (N))
and then Nkind (Next (N)) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name (Next (N))) = Pragma_Import
+ and then Get_Pragma_Id (Next (N)) = Pragma_Import
then
-- In SPARK, subprogram declarations are also permitted in
-- declarative parts when immediately followed by a corresponding
Create_Append (Checks,
Make_Pragma (Ploc,
- Pragma_Identifier =>
- Make_Identifier (Ploc, Name_Check),
+ Chars => Name_Check,
Pragma_Argument_Associations => Assoc));
end if;
Rep_Item := First_Rep_Item (T);
while Present (Rep_Item) loop
if Nkind (Rep_Item) = N_Pragma
- and then Pragma_Name (Rep_Item) = Name_Invariant
+ and then Pragma_Name_Mapped (Rep_Item) = Name_Invariant
then
-- Stop the traversal of the rep item chain once a specific
-- item is encountered.
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Contract_Cases
+ if Pragma_Name_Mapped (Prag) = Name_Contract_Cases
and then Is_Checked (Prag)
then
Has_Pragma := True;
Ritem := First_Rep_Item (Prot_Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Attach_Handler
+ and then Pragma_Name_Mapped (Ritem) = Name_Attach_Handler
then
Num_Attach_Handler := Num_Attach_Handler + 1;
end if;
N := First (Visible_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_Relative_Deadline
+ and then Pragma_Name_Mapped (N) = Name_Relative_Deadline
then
return N;
end if;
N := First (Private_Declarations (T));
while Present (N) loop
if Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_Relative_Deadline
+ and then Pragma_Name_Mapped (N) = Name_Relative_Deadline
then
return N;
end if;
-- Get_Rep_Item returns either priority pragma.
- if Pragma_Name (Prio_Clause) = Name_Priority then
+ if Pragma_Name_Mapped (Prio_Clause) = Name_Priority then
Prio_Type := RTE (RE_Any_Priority);
else
Prio_Type := RTE (RE_Interrupt_Priority);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Attach_Handler
+ and then Pragma_Name_Mapped (Ritem) = Name_Attach_Handler
then
declare
Handler : constant Node_Id :=
---------------------
procedure Expand_N_Pragma (N : Node_Id) is
- Pname : constant Name_Id := Pragma_Name (N);
+ Pname : constant Name_Id := Pragma_Name_Mapped (N);
begin
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
return;
end if;
- -- Note: we may have a pragma whose Pragma_Identifier field is not a
- -- recognized pragma, and we must ignore it at this stage.
+ case Get_Pragma_Id (Pname) is
- if Is_Pragma_Name (Pname) then
- case Get_Pragma_Id (Pname) is
+ -- Pragmas requiring special expander action
- -- Pragmas requiring special expander action
+ when Pragma_Abort_Defer =>
+ Expand_Pragma_Abort_Defer (N);
- when Pragma_Abort_Defer =>
- Expand_Pragma_Abort_Defer (N);
+ when Pragma_Check =>
+ Expand_Pragma_Check (N);
- when Pragma_Check =>
- Expand_Pragma_Check (N);
+ when Pragma_Common_Object =>
+ Expand_Pragma_Common_Object (N);
- when Pragma_Common_Object =>
- Expand_Pragma_Common_Object (N);
+ when Pragma_Import =>
+ Expand_Pragma_Import_Or_Interface (N);
- when Pragma_Import =>
- Expand_Pragma_Import_Or_Interface (N);
+ when Pragma_Inspection_Point =>
+ Expand_Pragma_Inspection_Point (N);
- when Pragma_Inspection_Point =>
- Expand_Pragma_Inspection_Point (N);
+ when Pragma_Interface =>
+ Expand_Pragma_Import_Or_Interface (N);
- when Pragma_Interface =>
- Expand_Pragma_Import_Or_Interface (N);
+ when Pragma_Interrupt_Priority =>
+ Expand_Pragma_Interrupt_Priority (N);
- when Pragma_Interrupt_Priority =>
- Expand_Pragma_Interrupt_Priority (N);
+ when Pragma_Loop_Variant =>
+ Expand_Pragma_Loop_Variant (N);
- when Pragma_Loop_Variant =>
- Expand_Pragma_Loop_Variant (N);
+ when Pragma_Psect_Object =>
+ Expand_Pragma_Psect_Object (N);
- when Pragma_Psect_Object =>
- Expand_Pragma_Psect_Object (N);
+ when Pragma_Relative_Deadline =>
+ Expand_Pragma_Relative_Deadline (N);
- when Pragma_Relative_Deadline =>
- Expand_Pragma_Relative_Deadline (N);
+ when Pragma_Suppress_Initialization =>
+ Expand_Pragma_Suppress_Initialization (N);
- when Pragma_Suppress_Initialization =>
- Expand_Pragma_Suppress_Initialization (N);
+ -- All other pragmas need no expander action (includes
+ -- Unknown_Pragma).
- -- All other pragmas need no expander action
-
- when others => null;
- end case;
- end if;
+ when others => null;
+ end case;
end Expand_N_Pragma;
if Relaxed_RM_Semantics
and then List_Length (Pragma_Argument_Associations (N)) = 2
- and then Chars (Pragma_Identifier (N)) = Name_Import
+ and then Pragma_Name_Mapped (N) = Name_Import
and then Nkind (Arg2 (N)) = N_String_Literal
then
Def_Id := Entity (Arg1 (N));
begin
if Nkind (N) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate
+ and then Get_Pragma_Id (N) = Pragma_Annotate
and then List_Length (Pragma_Argument_Associations (N)) = 2
then
declare
return
Make_Pragma (Loc,
- Pragma_Identifier => Make_Identifier (Loc, Name_Check),
+ Chars => Name_Check,
Pragma_Argument_Associations => Arg_List);
end Make_Predicate_Check;
if Present (Decl)
and then Nkind (Decl) = N_Pragma
- and then Pragma_Name (Decl) = Name_Import
+ and then Pragma_Name_Mapped (Decl) = Name_Import
then
return;
end if;
Item := First (Context_Items (Cunit (Main_Unit)));
while Present (Item) loop
if Nkind (Item) = N_Pragma
- and then Pragma_Name (Item) = Name_Initialize_Scalars
+ and then Pragma_Name_Mapped (Item) = Name_Initialize_Scalars
then
Initialize_Scalars := True;
end if;
while Present (Decl) loop
if Nkind (Decl) = N_Pragma
- and then Pragma_Name (Decl) = Name_Ghost
+ and then Pragma_Name_Mapped (Decl) = Name_Ghost
then
return
Enables_Ghostness (First (Pragma_Argument_Associations (Decl)));
-- not be posting warnings on the inlined body so it is unneeded.
elsif Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_Unreferenced
+ and then Pragma_Name_Mapped (N) = Name_Unreferenced
then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return OK;
Write_Info_Initiate ('N');
Write_Info_Char (' ');
- case Chars (Pragma_Identifier (N)) is
+ case Pragma_Name (N) is
when Name_Annotate =>
C := 'A';
when Name_Comment =>
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- Ada 2005 (AI-284): INTERFACE is a new reserved word but it is
-- allowed as a pragma name.
- if Ada_Version >= Ada_2005
- and then Token = Tok_Interface
- then
- Prag_Name := Name_Interface;
- Ident_Node := Make_Identifier (Token_Ptr, Name_Interface);
- Scan; -- past INTERFACE
+ if Is_Reserved_Keyword (Token) then
+ Prag_Name := Keyword_Name (Token);
+ Ident_Node := Make_Identifier (Token_Ptr, Prag_Name);
+ Scan; -- past the keyword
else
Ident_Node := P_Identifier;
end if;
Reserved_Words_OK : Boolean := False)
is
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.
+ -- Parse an expression or, if the token is one of the following reserved
+ -- words, construct an identifier with proper Chars field.
-- Access
-- Delta
-- Digits
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
end Initialize_Ada_Keywords;
+ ------------------
+ -- Keyword_Name --
+ ------------------
+
+ function Keyword_Name (Token : Token_Type) return Name_Id is
+ Tok : String := Token'Img;
+ pragma Assert (Tok (1 .. 4) = "TOK_");
+ Name : String renames Tok (5 .. Tok'Last);
+ begin
+ -- Convert to lower case. We don't want to add a dependence on a
+ -- general-purpose To_Lower routine, so we convert "by hand" here.
+ -- All keywords use 7-bit ASCII letters only, so this works.
+
+ for J in Name'Range loop
+ pragma Assert (Name (J) in 'A' .. 'Z');
+ Name (J) :=
+ Character'Val (Character'Pos (Name (J)) +
+ (Character'Pos ('a') - Character'Pos ('A')));
+ end loop;
+
+ return Name_Find (Name);
+ end Keyword_Name;
+
------------------------
-- Restore_Scan_State --
------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- The class column in this table indicates the token classes which
-- apply to the token, as defined by subsequent subtype declarations.
- -- Note: Namet.Is_Keyword_Name depends on the fact that the first entry in
- -- this type declaration is *not* for a reserved word. For details on why
- -- there is this requirement, see Initialize_Ada_Keywords below.
-
type Token_Type is (
-- Token name Token type Class(es)
-- No_Token is used for initializing Token values to indicate that
-- no value has been set yet.
+ function Keyword_Name (Token : Token_Type) return Name_Id;
+ -- Given a token that is a reserved word, return the corresponding Name_Id
+ -- in lower case. E.g. Keyword_Name (Tok_Begin) = Name_Find ("begin").
+ -- It is an error to pass any other kind of token.
+
-- Note: in the RM, operator symbol is a special case of string literal.
-- We distinguish at the lexical level in this compiler, since there are
-- many syntactic situations in which only an operator symbol is allowed.
if Nkind (Prag) = N_Aspect_Specification then
Prag_Nam := Chars (Identifier (Prag));
else
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam := Pragma_Name_Mapped (Prag);
end if;
if Prag_Nam = Name_Check then
and then
(Pragma_Name (N) = Nam
or else (Nam = Name_Priority
- and then Pragma_Name (N) = Name_Interrupt_Priority)
+ and then Pragma_Name_Mapped (N) =
+ Name_Interrupt_Priority)
or else (Nam = Name_Interrupt_Priority
- and then Pragma_Name (N) = Name_Priority))
+ and then Pragma_Name_Mapped (N) = Name_Priority))
then
if Check_Parents then
return N;
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Pragma_Name (Item) in Configuration_Pragma_Names
+ and then Pragma_Name_Mapped (Item) in Configuration_Pragma_Names
loop
Analyze (Item);
Next (Item);
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Pragma_Name (Item) in Configuration_Pragma_Names
+ and then Pragma_Name_Mapped (Item) in Configuration_Pragma_Names
loop
Next (Item);
end loop;
Check_Declarations (Specification (Decl));
elsif Nkind (Decl) = N_Pragma
- and then Pragma_Name (Decl) = Name_Import
+ and then Pragma_Name_Mapped (Decl) = Name_Import
then
Check_Pragma_Import (Decl);
end if;
Append_Elmt (Decl, Incomplete_Decls);
elsif Nkind (Decl) = N_Pragma
- and then Pragma_Name (Decl) = Name_Import
+ and then Pragma_Name_Mapped (Decl) = Name_Import
then
Check_Pragma_Import (Decl);
end if;
Decl := First (Decls);
while Present (Decl) and then Nkind (Decl) = N_Pragma loop
- if Pragma_Name (Decl) = Name_Abstract_State then
+ if Pragma_Name_Mapped (Decl) = Name_Abstract_State then
Process_State
(Get_Pragma_Arg
(First (Pragma_Argument_Associations (Decl))));
-- The only pragma of interest is Complete_Representation
- if Pragma_Name (CC) = Name_Complete_Representation then
+ if Pragma_Name_Mapped (CC) = Name_Complete_Representation then
CR_Pragma := CC;
end if;
Ritem := First_Rep_Item (Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Predicate
+ and then Pragma_Name_Mapped (Ritem) = Name_Predicate
then
Add_Predicate (Ritem);
begin
if Nkind (Prag) = N_Pragma
- and then Pragma_Name (Prag) = Name_Predicate
+ and then Pragma_Name_Mapped (Prag) = Name_Predicate
then
Add_Predicate (Prag);
end if;
if Is_Overloadable (T) and then Nkind (N) = N_Pragma then
declare
- Pname : constant Name_Id := Pragma_Name (N);
+ Pname : constant Name_Id := Pragma_Name_Mapped (N);
begin
if Nam_In (Pname, Name_Convention, Name_Import, Name_Export,
Name_External, Name_Interface)
procedure No_Independence is
begin
- if Pragma_Name (N) = Name_Independent then
+ if Pragma_Name_Mapped (N) = Name_Independent then
Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
else
Error_Msg_NE
for J in Independence_Checks.First .. Independence_Checks.Last loop
N := Independence_Checks.Table (J).N;
E := Independence_Checks.Table (J).E;
- IC := Pragma_Name (N) = Name_Independent_Components;
+ IC := Pragma_Name_Mapped (N) = Name_Independent_Components;
-- Deal with component case
Analyze (Prag);
Set_Has_Pragma_Inline (Subp);
- if Pragma_Name (Prag) = Name_Inline_Always then
+ if Pragma_Name_Mapped (Prag) = Name_Inline_Always then
Set_Is_Inlined (Subp);
Set_Has_Pragma_Inline_Always (Subp);
end if;
begin
if Nkind (Orig) = N_Pragma
- and then Pragma_Name (Orig) = Name_Assert
+ and then Pragma_Name_Mapped (Orig) = Name_Assert
and then not Error_Posted (Orig)
then
declare
if Class_Present (Prag)
and then not Split_PPC (Prag)
then
- if Pragma_Name (Prag) = Name_Precondition then
+ if Pragma_Name_Mapped (Prag) = Name_Precondition then
Error_Msg_N
("info: & inherits `Pre''Class` aspect from "
& "#?L?", E);
elsif Kind = N_Pragma then
declare
- Prag_Name : constant Name_Id := Pragma_Name (N);
+ Prag_Name : constant Name_Id :=
+ Pragma_Name_Mapped (N);
Prag_Id : constant Pragma_Id :=
- Get_Pragma_Id (Prag_Name);
+ Get_Pragma_Id (Prag_Name);
begin
if Prag_Id = Pragma_Export
-- Pragma case
else
- Error_Msg_Name_1 := Pragma_Name (Prio_Item);
+ Error_Msg_Name_1 := Pragma_Name_Mapped (Prio_Item);
Error_Msg_NE
("pragma% for & has no effect when Lock_Free given??",
Prio_Item, Id);
-- Pragma case
elsif Nkind (Prio_Item) = N_Pragma
- and then Pragma_Name (Prio_Item) = Name_Priority
+ and then Pragma_Name_Mapped (Prio_Item) = Name_Priority
then
Error_Msg_N
("pragma Interrupt_Priority is preferred in presence of "
Par := Call;
while Present (Par) loop
if Nkind (Par) = N_Pragma then
- Nam := Pragma_Name (Par);
+ Nam := Pragma_Name_Mapped (Par);
-- Pragma Initial_Condition appears in its alternative from as
-- Check (Initial_Condition, ...).
-- Or, in the case of an initial condition, specifically by a
-- Check pragma specifying an Initial_Condition check.
- elsif Pragma_Name (O) = Name_Check
+ elsif Pragma_Name_Mapped (O) = Name_Check
and then
Chars
(Expression (First (Pragma_Argument_Associations (O)))) =
Item := First (Context_Items (CU));
while Present (Item) loop
if Nkind (Item) = N_Pragma
- and then Pragma_Name (Item) = Name_Elaborate_All
+ and then Pragma_Name_Mapped (Item) = Name_Elaborate_All
then
-- Return if some previous error on the pragma itself. The
-- pragma may be unanalyzed, because of a previous error, or
return;
end if;
- Error_Msg_Name_1 := Pragma_Name (N);
+ Error_Msg_Name_1 := Pragma_Name_Mapped (N);
-- An external property pragma must apply to an effectively volatile
-- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
-- previously given aspect specification or attribute definition
-- clause for the same pragma.
- P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
+ P := Get_Rep_Item (E, Pragma_Name_Mapped (N), Check_Parents => False);
if Present (P) then
-- Here we have a definite duplicate
- Error_Msg_Name_1 := Pragma_Name (N);
+ Error_Msg_Name_1 := Pragma_Name_Mapped (N);
Error_Msg_Sloc := Sloc (P);
-- For a single protected or a single task object, the error is
if Is_Rewrite_Substitution (N)
and then Nkind (Original_Node (N)) = N_Pragma
then
- Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
+ Error_Msg_Name_1 := Pragma_Name_Mapped (Original_Node (N));
end if;
-- Case where pragma comes from an aspect specification
if Nam_In (Pragma_Name (Decl), Name_Export,
Name_Convention,
- Pragma_Name (N))
+ Pragma_Name_Mapped (N))
then
exit;
-- Deal with unrecognized pragma
- Pname := Pragma_Name (N);
+ Pname := Pragma_Name_Mapped (N);
if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
-- Skip prior pragmas, but check for duplicates
if Nkind (Stmt) = N_Pragma then
- if Pragma_Name (Stmt) = Pname then
+ if Pragma_Name_Mapped (Stmt) = Pname then
Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (Stmt);
Error_Msg_N ("pragma % duplicates pragma declared#", N);
-- Skip prior pragmas, but check for duplicates
if Nkind (Stmt) = N_Pragma then
- if Pragma_Name (Stmt) = Pname then
+ if Pragma_Name_Mapped (Stmt) = Pname then
Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (Stmt);
Error_Msg_N ("pragma % duplicates pragma declared#", N);
if Is_Imported (Def_Id)
and then Present (First_Rep_Item (Def_Id))
and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
- and then Pragma_Name (First_Rep_Item (Def_Id)) =
+ and then Pragma_Name_Mapped (First_Rep_Item (Def_Id)) =
Name_Interface
then
null;
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Pragma_Name (Nod) = Name_Main
+ and then Pragma_Name_Mapped (Nod) = Name_Main
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Pragma_Name (Nod) = Name_Main_Storage
+ and then Pragma_Name_Mapped (Nod) = Name_Main_Storage
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
-- pragma Rename_Pragma (
-- [New_Name =>] IDENTIFIER,
- -- [Renames =>] pragma_IDENTIFIER);
-
- -- ??? this is work in progress
+ -- [Renamed =>] pragma_IDENTIFIER);
pragma Warnings (Off);
when Pragma_Rename_Pragma => Rename_Pragma : declare
- GNAT_Pragma_Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
- Synonym : constant Node_Id := Get_Pragma_Arg (Arg1);
-
+ New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
begin
GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_New_Name);
- Check_Optional_Identifier (Arg2, Name_Renames);
+ Check_Optional_Identifier (Arg2, Name_Renamed);
+
+ if Nkind (New_Name) /= N_Identifier then
+ Error_Pragma_Arg ("identifier expected", Arg1);
+ end if;
+
+ if Nkind (Old_Name) /= N_Identifier then
+ Error_Pragma_Arg ("identifier expected", Arg2);
+ end if;
+
+ -- The New_Name arg should not be an existing pragma (but we allow
+ -- it; it's just a warning). The Old_Name arg must be an existing
+ -- pragma.
+
+ if Is_Pragma_Name (Chars (New_Name)) then
+ Error_Pragma_Arg ("??pragma is already defined", Arg1);
+ end if;
+
+ if not Is_Pragma_Name (Chars (Old_Name)) then
+ Error_Pragma_Arg ("existing pragma name expected", Arg1);
+ end if;
+
+ Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
end Rename_Pragma;
pragma Warnings (On);
Import :=
Make_Pragma (Loc,
- Chars => Name_Import,
+ Chars => Name_Import,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Intrinsic)),
-- this also takes care of pragmas generated for aspects.
if Nkind (Stmt) = N_Pragma then
- if Pragma_Name (Stmt) = Pname then
+ if Pragma_Name_Mapped (Stmt) = Pname then
Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (Stmt);
Error_Msg_N ("pragma% duplicates pragma declared#", N);
if Present (Items) then
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Test_Case
+ if Pragma_Name_Mapped (Prag) = Name_Test_Case
and then Prag /= N
and then String_Equal
(Name, Get_Name_From_CTC_Pragma (Prag))
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Pragma_Name (Nod) = Name_Time_Slice
+ and then Pragma_Name_Mapped (Nod) = Name_Time_Slice
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
-- Local variables
Loc : constant Source_Ptr := Sloc (Prag);
- Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name_Mapped (Prag);
Check_Prag : Node_Id;
Msg_Arg : Node_Id;
Nam : Name_Id;
-- Skip prior pragmas, but check for duplicates
if Nkind (Stmt) = N_Pragma then
- if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
+ if Do_Checks
+ and then Pragma_Name_Mapped (Stmt) = Pragma_Name_Mapped (Prag)
+ then
Duplication_Error
(Prag => Prag,
Prev => Stmt);
Do_Checks : Boolean := False) return Node_Id
is
Context : constant Node_Id := Parent (Prag);
- Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name_Mapped (Prag);
Stmt : Node_Id;
begin
-- Skip prior pragmas, but check for duplicates
if Nkind (Stmt) = N_Pragma then
- if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
+ if Do_Checks and then Pragma_Name_Mapped (Stmt) = Prag_Nam then
Duplication_Error
(Prag => Prag,
Prev => Stmt);
begin
pragma Assert
(Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_SPARK_Mode
+ and then Pragma_Name_Mapped (N) = Name_SPARK_Mode
and then Is_List_Member (N));
-- Pragma SPARK_Mode affects the elaboration of a package body when it
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
Pragn : constant Node_Id := Parent (Par);
Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
- Pname : constant Name_Id := Pragma_Name (Pragn);
+ Pname : constant Name_Id := Pragma_Name_Mapped (Pragn);
Argn : Natural;
N : Node_Id;
begin
pragma Assert
(Nkind (N) = N_Pragma
- and then Pragma_Name (N) = Name_SPARK_Mode
+ and then Pragma_Name_Mapped (N) = Name_SPARK_Mode
and then Is_List_Member (N));
-- For pragma SPARK_Mode to be private, it has to appear in the private
-- Special handling of Asssert pragma
if Nkind (Orig) = N_Pragma
- and then Pragma_Name (Orig) = Name_Assert
+ and then Pragma_Name_Mapped (Orig) = Name_Assert
then
declare
Expr : constant Node_Id :=
-- Similar processing for Check pragma
elsif Nkind (Orig) = N_Pragma
- and then Pragma_Name (Orig) = Name_Check
+ and then Pragma_Name_Mapped (Orig) = Name_Check
then
-- Don't want to warn if original condition is explicit False
Stmt :=
Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Name_Check),
-
+ Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
Par := Parent (Ref);
while Present (Par) loop
if Nkind (Par) = N_Pragma then
- Prag_Nam := Pragma_Name (Par);
+ Prag_Nam := Pragma_Name_Mapped (Par);
-- A concurrent constituent is allowed to appear in pragmas
-- Initial_Condition and Initializes as this is part of the
Check_Function_Result (Expr);
if not Mentions_Post_State (Expr) then
- if Pragma_Name (Prag) = Name_Contract_Cases then
+ if Pragma_Name_Mapped (Prag) = Name_Contract_Cases then
Error_Msg_NE
("contract case does not check the outcome of calling "
& "&?T?", Expr, Subp_Id);
- elsif Pragma_Name (Prag) = Name_Refined_Post then
+ elsif Pragma_Name_Mapped (Prag) = Name_Refined_Post then
Error_Msg_NE
("refined postcondition does not check the outcome of "
& "calling &?T?", Prag, Subp_Id);
Expr : constant Node_Id :=
Get_Pragma_Arg
(First (Pragma_Argument_Associations (Prag)));
- Nam : constant Name_Id := Pragma_Name (Prag);
+ Nam : constant Name_Id := Pragma_Name_Mapped (Prag);
CCase : Node_Id;
-- Start of processing for Check_Result_And_Post_State_In_Pragma
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Contract_Cases
+ if Pragma_Name_Mapped (Prag) = Name_Contract_Cases
and then not Error_Posted (Prag)
then
Case_Prag := Prag;
Arg : constant Node_Id :=
Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
- Nam : constant Name_Id := Pragma_Name (Prag);
+ Nam : constant Name_Id := Pragma_Name_Mapped (Prag);
-- Start of processing for Contains_Refined_State
Decl := Next (Unit_Declaration_Node (Subp));
while Present (Decl) loop
if Nkind (Decl) = N_Pragma
- and then Pragma_Name (Decl) = Name_Extensions_Visible
+ and then Pragma_Name_Mapped (Decl) = Name_Extensions_Visible
then
Prag := Decl;
exit;
loop
if No (P) then
return False;
- elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
+ elsif Nkind (P) = N_Pragma and then Pragma_Name_Mapped (P) = Nam then
return True;
else
P := Parent (P);
elsif Nkind (P) = N_Pragma
and then
- Get_Pragma_Id (Pragma_Name (P)) = Pragma_Predicate_Failure
+ Get_Pragma_Id (P) = Pragma_Predicate_Failure
then
return True;
end if;
Nam := Chars (Identifier (Item));
else pragma Assert (Nkind (Item) = N_Pragma);
- Nam := Pragma_Name (Item);
+ Nam := Pragma_Name_Mapped (Item);
end if;
return Nam = Name_Abstract_State
Nam := Chars (Identifier (Item));
else pragma Assert (Nkind (Item) = N_Pragma);
- Nam := Pragma_Name (Item);
+ Nam := Pragma_Name_Mapped (Item);
end if;
return Nam = Name_Contract_Cases
function Get_Pragma_Id (N : Node_Id) return Pragma_Id;
pragma Inline (Get_Pragma_Id);
- -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
+ -- Obtains the Pragma_Id from Pragma_Name (N)
function Get_Qualified_Name
(Id : Entity_Id;
P := Parent (Nod);
if Nkind (P) = N_Pragma
- and then Pragma_Name (P) = Name_Test_Case
+ and then Pragma_Name_Mapped (P) =
+ Name_Test_Case
and then Nod = Test_Case_Arg (P, Name_Ensures)
then
return True;
-- Map_Pragma_Name --
---------------------
+ -- We don't want to introduce a dependence on some hash table package or
+ -- similar, so we use a simple array of Key => Value pairs, and do a linear
+ -- search. Linear search is plenty efficient, given that we don't expect
+ -- more than a couple of entries in the mapping.
+
+ type Name_Pair is record
+ Key : Name_Id;
+ Value : Name_Id;
+ end record;
+
+ type Pragma_Map_Index is range 1 .. 100;
+ Pragma_Map : array (Pragma_Map_Index) of Name_Pair;
+ Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0;
+
procedure Map_Pragma_Name (From, To : Name_Id) is
begin
- null; -- not yet implemented
+ if Last_Pair = Pragma_Map'Last then
+ raise Too_Many_Pragma_Mappings;
+ end if;
+
+ Last_Pair := Last_Pair + 1;
+ Pragma_Map (Last_Pair) := (Key => From, Value => To);
end Map_Pragma_Name;
------------------------
------------------------
function Pragma_Name_Mapped (N : Node_Id) return Name_Id is
+ Result : constant Name_Id := Pragma_Name (N);
begin
- return Pragma_Name (N);
+ for J in Pragma_Map'Range loop
+ if Result = Pragma_Map (J).Key then
+ return Pragma_Map (J).Value;
+ end if;
+ end loop;
+
+ return Result;
end Pragma_Name_Mapped;
end Sinfo;
procedure Map_Pragma_Name (From, To : Name_Id);
-- Used in the implementation of pragma Rename_Pragma. Maps pragma name
- -- From to pragma name To, we From can be used as a synonym for To.
+ -- From to pragma name To, so From can be used as a synonym for To.
+
+ Too_Many_Pragma_Mappings : exception;
+ -- Raised if Map_Pragma_Name is called too many times. We expect that few
+ -- programs will use it at all, and those that do will use it approximately
+ -- once or twice.
function Pragma_Name_Mapped (N : Node_Id) return Name_Id;
- -- ????Work in progress.
+ -- Same as Pragma_Name, except that if From has been mapped to To, and
+ -- Pragma_Name (N) = From, then this returns To.
-----------------------------
-- Syntactic Parent Tables --
Name_Proof_In : constant Name_Id := N + $;
Name_Reason : constant Name_Id := N + $;
Name_Reference : constant Name_Id := N + $;
+ Name_Renamed : constant Name_Id := N + $;
Name_Requires : constant Name_Id := N + $;
Name_Restricted : constant Name_Id := N + $;
Name_Result_Mechanism : constant Name_Id := N + $;
projects / gcc.git / commitdiff