Skip to content

R
riscv-gcc-1
Commit 9d5598bf by Arnaud Charlet
Options

[multiple changes] 

2013-04-23  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Significant
	rewrite to make sure Is_Ignore is properly captured when aspect
	is declared.
	* sem_ch6.adb: Minor reformatting.
	* sem_prag.adb (Analyze_Pragma): Do not test policy at time of
	pragma for the case of a pragma coming from an aspect (already
	tested when we analyzed the aspect).

2013-04-23  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Parse_Project_And_Apply_Config): New
	Boolean parameter Implicit_Project, defaulted to False. Call
	Prj.Part.Parse with Implicit_Project.
	* prj-conf.ads (Parse_Project_And_Apply_Config): New Boolean
	parameter Implicit_Project, defaulted to False.
	* prj-part.adb (Parse_Single_Project): New Boolean parameter
	Implicit_Project, defaulted to False. When Implicit_Project is
	True, change the Directory of the project node to the Current_Dir.
	* prj-part.ads (Parse): New Boolean parameter, defaulted to False

2013-04-23  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb: Minor reformatting.

From-SVN: r198184
parent 72267417
Showing with 325 additions and 206 deletions
gcc/ada/ChangeLog
2013-04-23 Robert Dewar <dewar@adacore.com> 2013-04-23 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Significant
rewrite to make sure Is_Ignore is properly captured when aspect
is declared.
* sem_ch6.adb: Minor reformatting.
* sem_prag.adb (Analyze_Pragma): Do not test policy at time of
pragma for the case of a pragma coming from an aspect (already
tested when we analyzed the aspect).
2013-04-23 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Parse_Project_And_Apply_Config): New
Boolean parameter Implicit_Project, defaulted to False. Call
Prj.Part.Parse with Implicit_Project.
* prj-conf.ads (Parse_Project_And_Apply_Config): New Boolean
parameter Implicit_Project, defaulted to False.
* prj-part.adb (Parse_Single_Project): New Boolean parameter
Implicit_Project, defaulted to False. When Implicit_Project is
True, change the Directory of the project node to the Current_Dir.
* prj-part.ads (Parse): New Boolean parameter, defaulted to False
2013-04-23 Robert Dewar <dewar@adacore.com>
* exp_util.adb: Minor reformatting.
2013-04-23 Robert Dewar <dewar@adacore.com>
* xoscons.adb: Minor reformatting. * xoscons.adb: Minor reformatting.
2013-04-23 Hristian Kirtchev <kirtchev@adacore.com> 2013-04-23 Hristian Kirtchev <kirtchev@adacore.com>
......
gcc/ada/exp_util.adb
...@@ -2586,9 +2586,11 @@ package body Exp_Util is ...@@ -2586,9 +2586,11 @@ package body Exp_Util is
begin begin
Start_String; Start_String;
Internal_Full_Qualified_Name (E); Internal_Full_Qualified_Name (E);
if Append_NUL then if Append_NUL then
Store_String_Char (Get_Char_Code (ASCII.NUL)); Store_String_Char (Get_Char_Code (ASCII.NUL));
end if; end if;
return End_String; return End_String;
end Fully_Qualified_Name_String; end Fully_Qualified_Name_String;
......
gcc/ada/prj-conf.adb
...@@ -1558,7 +1558,8 @@ package body Prj.Conf is ...@@ -1558,7 +1558,8 @@ package body Prj.Conf is
Config_File_Path : out String_Access; Config_File_Path : out String_Access;
Target_Name : String := ""; Target_Name : String := "";
Normalized_Hostname : String; Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null) On_Load_Config : Config_File_Hook := null;
Implicit_Project : Boolean := False)
is is
begin begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
...@@ -1578,7 +1579,8 @@ package body Prj.Conf is ...@@ -1578,7 +1579,8 @@ package body Prj.Conf is
Packages_To_Check => Packages_To_Check, Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory, Current_Directory => Current_Directory,
Is_Config_File => False, Is_Config_File => False,
Env => Env); Env => Env,
Implicit_Project => Implicit_Project);
if User_Project_Node = Empty_Node then if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node; User_Project_Node := Empty_Node;
......
gcc/ada/prj-conf.ads
...@@ -55,7 +55,8 @@ package Prj.Conf is ...@@ -55,7 +55,8 @@ package Prj.Conf is
Config_File_Path : out String_Access; Config_File_Path : out String_Access;
Target_Name : String := ""; Target_Name : String := "";
Normalized_Hostname : String; Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null); On_Load_Config : Config_File_Hook := null;
Implicit_Project : Boolean := False);
-- Find the main configuration project and parse the project tree rooted at -- Find the main configuration project and parse the project tree rooted at
-- this configuration project. -- this configuration project.
-- --
...@@ -85,6 +86,11 @@ package Prj.Conf is ...@@ -85,6 +86,11 @@ package Prj.Conf is
-- Any error in generating or parsing the config file is reported via the -- Any error in generating or parsing the config file is reported via the
-- Invalid_Config exception, with an appropriate message. Any error while -- Invalid_Config exception, with an appropriate message. Any error while
-- parsing the project file results in No_Project. -- parsing the project file results in No_Project.
--
-- If Implicit_Project is True, the main project file being parsed is
-- deemed to be in the current working directory, even if it is not the
-- case.
-- Why is this ever useful???
procedure Process_Project_And_Apply_Config procedure Process_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id; (Main_Project : out Prj.Project_Id;
......
gcc/ada/prj-part.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,8 @@ package body Prj.Part is ...@@ -191,7 +191,8 @@ package body Prj.Part is
Depth : Natural; Depth : Natural;
Current_Dir : String; Current_Dir : String;
Is_Config_File : Boolean; Is_Config_File : Boolean;
Env : in out Environment); Env : in out Environment;
Implicit_Project : Boolean := False);
-- Parse a project file. This is a recursive procedure: it calls itself for -- Parse a project file. This is a recursive procedure: it calls itself for
-- imported and extended projects. When From_Extended is not None, if the -- imported and extended projects. When From_Extended is not None, if the
-- project has already been parsed and is an extended project A, return the -- project has already been parsed and is an extended project A, return the
...@@ -201,6 +202,10 @@ package body Prj.Part is ...@@ -201,6 +202,10 @@ package body Prj.Part is
-- --
-- Is_Config_File should be set to True if the project represents a config -- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply. -- file (.cgpr) since some specific checks apply.
--
-- If Implicit_Project is True, change the Directory of the project node
-- to be the Current_Dir. Recursive calls to Parse_Single_Project are
-- always done with the default False value for Implicit_Project.
procedure Pre_Parse_Context_Clause procedure Pre_Parse_Context_Clause
(In_Tree : Project_Node_Tree_Ref; (In_Tree : Project_Node_Tree_Ref;
...@@ -530,7 +535,8 @@ package body Prj.Part is ...@@ -530,7 +535,8 @@ package body Prj.Part is
Current_Directory : String := ""; Current_Directory : String := "";
Is_Config_File : Boolean; Is_Config_File : Boolean;
Env : in out Prj.Tree.Environment; Env : in out Prj.Tree.Environment;
Target_Name : String := "") Target_Name : String := "";
Implicit_Project : Boolean := False)
is is
Dummy : Boolean; Dummy : Boolean;
pragma Warnings (Off, Dummy); pragma Warnings (Off, Dummy);
...@@ -598,7 +604,8 @@ package body Prj.Part is ...@@ -598,7 +604,8 @@ package body Prj.Part is
Depth => 0, Depth => 0,
Current_Dir => Current_Directory, Current_Dir => Current_Directory,
Is_Config_File => Is_Config_File, Is_Config_File => Is_Config_File,
Env => Env); Env => Env,
Implicit_Project => Implicit_Project);
exception exception
when Types.Unrecoverable_Error => when Types.Unrecoverable_Error =>
...@@ -1230,7 +1237,8 @@ package body Prj.Part is ...@@ -1230,7 +1237,8 @@ package body Prj.Part is
Depth : Natural; Depth : Natural;
Current_Dir : String; Current_Dir : String;
Is_Config_File : Boolean; Is_Config_File : Boolean;
Env : in out Environment) Env : in out Environment;
Implicit_Project : Boolean := False)
is is
Path_Name : constant String := Get_Name_String (Path_Name_Id); Path_Name : constant String := Get_Name_String (Path_Name_Id);
...@@ -1394,7 +1402,10 @@ package body Prj.Part is ...@@ -1394,7 +1402,10 @@ package body Prj.Part is
Tree.Reset_State; Tree.Reset_State;
Scan (In_Tree); Scan (In_Tree);
if not Is_Config_File and then Name_From_Path = No_Name then if not Is_Config_File
and then Name_From_Path = No_Name
and then not Implicit_Project
then
-- The project file name is not correct (no or bad extension, or not -- The project file name is not correct (no or bad extension, or not
-- following Ada identifier's syntax). -- following Ada identifier's syntax).
...@@ -1977,6 +1988,13 @@ package body Prj.Part is ...@@ -1977,6 +1988,13 @@ package body Prj.Part is
Tree.Restore_And_Free (Project_Comment_State); Tree.Restore_And_Free (Project_Comment_State);
Debug_Decrease_Indent; Debug_Decrease_Indent;
if Project /= Empty_Node and then Implicit_Project then
Name_Len := 0;
Add_Str_To_Name_Buffer (Current_Dir);
Add_Char_To_Name_Buffer (Dir_Sep);
In_Tree.Project_Nodes.Table (Project).Directory := Name_Find;
end if;
end Parse_Single_Project; end Parse_Single_Project;
----------------------- -----------------------
......
gcc/ada/prj-part.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -47,7 +47,8 @@ package Prj.Part is ...@@ -47,7 +47,8 @@ package Prj.Part is
Current_Directory : String := ""; Current_Directory : String := "";
Is_Config_File : Boolean; Is_Config_File : Boolean;
Env : in out Prj.Tree.Environment; Env : in out Prj.Tree.Environment;
Target_Name : String := ""); Target_Name : String := "";
Implicit_Project : Boolean := False);
-- Parse project file and all its imported project files and create a tree. -- Parse project file and all its imported project files and create a tree.
-- Return the node for the project (or Empty_Node if parsing failed). If -- Return the node for the project (or Empty_Node if parsing failed). If
-- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
...@@ -66,5 +67,10 @@ package Prj.Part is ...@@ -66,5 +67,10 @@ package Prj.Part is
-- Target_Name will be used to initialize the default project path, unless -- Target_Name will be used to initialize the default project path, unless
-- In_Tree.Project_Path has already been initialized (which is the -- In_Tree.Project_Path has already been initialized (which is the
-- recommended use). -- recommended use).
--
-- If Implicit_Project is True, the main project file being parsed is
-- deemed to be in the current working directory, even if it is not the
-- case.
-- Why is this ever useful???
end Prj.Part; end Prj.Part;
gcc/ada/sem_ch13.adb
...@@ -961,7 +961,7 @@ package body Sem_Ch13 is ...@@ -961,7 +961,7 @@ package body Sem_Ch13 is
Aspect := First (L); Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop Aspect_Loop : while Present (Aspect) loop
declare Analyze_One_Aspect : declare
Expr : constant Node_Id := Expression (Aspect); Expr : constant Node_Id := Expression (Aspect);
Id : constant Node_Id := Identifier (Aspect); Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect); Loc : constant Source_Ptr := Sloc (Aspect);
...@@ -977,12 +977,22 @@ package body Sem_Ch13 is ...@@ -977,12 +977,22 @@ package body Sem_Ch13 is
-- is set below when Expr is present. -- is set below when Expr is present.
procedure Analyze_Aspect_External_Or_Link_Name; procedure Analyze_Aspect_External_Or_Link_Name;
-- This routine performs the analysis of the External_Name or -- Perform analysis of the External_Name or Link_Name aspects
-- Link_Name aspects.
procedure Analyze_Aspect_Implicit_Dereference; procedure Analyze_Aspect_Implicit_Dereference;
-- This routine performs the analysis of the Implicit_Dereference -- Perform analysis of the Implicit_Dereference aspects
-- aspects.
procedure Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id);
-- This is a wrapper for Make_Pragma used for converting aspects
-- to pragmas. It takes care of Sloc (set from Loc) and building
-- the pragma identifier from the given name. In addition the
-- flags Class_Present and Split_PPC are set from the aspect
-- node, as well as Is_Ignored. This routine also sets the
-- From_Aspect_Specification in the resulting pragma node to
-- True, and sets Corresponding_Aspect to point to the aspect.
-- The resulting pragma is assigned to Aitem.
------------------------------------------ ------------------------------------------
-- Analyze_Aspect_External_Or_Link_Name -- -- Analyze_Aspect_External_Or_Link_Name --
...@@ -1051,6 +1061,42 @@ package body Sem_Ch13 is ...@@ -1051,6 +1061,42 @@ package body Sem_Ch13 is
end if; end if;
end Analyze_Aspect_Implicit_Dereference; end Analyze_Aspect_Implicit_Dereference;
-----------------------
-- Make_Aitem_Pragma --
-----------------------
procedure Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id)
is
begin
-- We should never get here if aspect was disabled
pragma Assert (not Is_Disabled (Aspect));
-- Build the pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations =>
Pragma_Argument_Associations,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Pragma_Name),
Class_Present => Class_Present (Aspect),
Split_PPC => Split_PPC (Aspect));
-- Set additional semantic fields
if Is_Ignored (Aspect) then
Set_Is_Ignored (Aitem);
end if;
Set_Corresponding_Aspect (Aitem, Aspect);
Set_From_Aspect_Specification (Aitem, True);
end Make_Aitem_Pragma;
-- Start of processing for Analyze_One_Aspect
begin begin
-- Skip aspect if already analyzed (not clear if this is needed) -- Skip aspect if already analyzed (not clear if this is needed)
...@@ -1059,7 +1105,8 @@ package body Sem_Ch13 is ...@@ -1059,7 +1105,8 @@ package body Sem_Ch13 is
end if; end if;
-- Skip looking at aspect if it is totally disabled. Just mark -- Skip looking at aspect if it is totally disabled. Just mark
-- it as such for later reference in the tree. -- it as such for later reference in the tree. This also sets
-- the Is_Ignored flag appropriately.
Check_Applicable_Policy (Aspect); Check_Applicable_Policy (Aspect);
...@@ -1218,36 +1265,32 @@ package body Sem_Ch13 is ...@@ -1218,36 +1265,32 @@ package body Sem_Ch13 is
-- referring to the entity, and the second argument is the -- referring to the entity, and the second argument is the
-- aspect definition expression. -- aspect definition expression.
-- Suppress/Unsuppress
when Aspect_Suppress | when Aspect_Suppress |
Aspect_Unsuppress => Aspect_Unsuppress =>
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc,
Make_Pragma_Argument_Association (Loc, Expression => New_Occurrence_Of (E, Loc)),
Expression => New_Occurrence_Of (E, Loc)), Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Make_Pragma_Argument_Association (Sloc (Expr), Pragma_Name => Chars (Id));
Expression => Relocate_Node (Expr))),
Pragma_Identifier => -- Synchronization
Make_Identifier (Sloc (Id), Chars (Id)));
-- The aspect corresponds to pragma Implemented. Construct the -- Corresponds to pragma Implemented, construct the pragma
-- pragma.
when Aspect_Synchronization => when Aspect_Synchronization =>
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Identifier => Make_Aitem_Pragma
Make_Identifier (Sloc (Id), Name_Implemented)); (Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Implemented);
-- No delay is required since the only values are: By_Entry -- No delay is required since the only values are: By_Entry
-- | By_Protected_Procedure | By_Any | Optional which don't -- | By_Protected_Procedure | By_Any | Optional which don't
...@@ -1255,16 +1298,18 @@ package body Sem_Ch13 is ...@@ -1255,16 +1298,18 @@ package body Sem_Ch13 is
Delay_Required := False; Delay_Required := False;
-- Attach Handler
when Aspect_Attach_Handler => when Aspect_Attach_Handler =>
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Identifier => Make_Pragma_Argument_Association (Sloc (Ent),
Make_Identifier (Sloc (Id), Name_Attach_Handler), Expression => Ent),
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Expr),
Make_Pragma_Argument_Association (Sloc (Ent), Expression => Relocate_Node (Expr))),
Expression => Ent), Pragma_Name => Name_Attach_Handler);
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)))); -- Dynamic_Predicate, Predicate, Static_Predicate
when Aspect_Dynamic_Predicate | when Aspect_Dynamic_Predicate |
Aspect_Predicate | Aspect_Predicate |
...@@ -1274,16 +1319,13 @@ package body Sem_Ch13 is ...@@ -1274,16 +1319,13 @@ package body Sem_Ch13 is
-- flags recording whether it is static/dynamic). We also -- flags recording whether it is static/dynamic). We also
-- set flags recording this in the type itself. -- set flags recording this in the type itself.
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent),
Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent),
Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr),
Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))),
Expression => Relocate_Node (Expr))), Pragma_Name => Name_Predicate);
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Predicate));
-- Mark type has predicates, and remember what kind of -- Mark type has predicates, and remember what kind of
-- aspect lead to this predicate (we need this to access -- aspect lead to this predicate (we need this to access
...@@ -1301,9 +1343,7 @@ package body Sem_Ch13 is ...@@ -1301,9 +1343,7 @@ package body Sem_Ch13 is
-- has a freeze node, because that is the one that will be -- has a freeze node, because that is the one that will be
-- visible at freeze time. -- visible at freeze time.
if Is_Private_Type (E) if Is_Private_Type (E) and then Present (Full_View (E)) then
and then Present (Full_View (E))
then
Set_Has_Predicates (Full_View (E)); Set_Has_Predicates (Full_View (E));
if A_Id = Aspect_Dynamic_Predicate then if A_Id = Aspect_Dynamic_Predicate then
...@@ -1321,6 +1361,8 @@ package body Sem_Ch13 is ...@@ -1321,6 +1361,8 @@ package body Sem_Ch13 is
-- referring to the entity, and the first argument is the -- referring to the entity, and the first argument is the
-- aspect definition expression. -- aspect definition expression.
-- Convention
when Aspect_Convention => when Aspect_Convention =>
-- The aspect may be part of the specification of an import -- The aspect may be part of the specification of an import
...@@ -1387,30 +1429,28 @@ package body Sem_Ch13 is ...@@ -1387,30 +1429,28 @@ package body Sem_Ch13 is
Append_To (Arg_List, E_Assoc); Append_To (Arg_List, E_Assoc);
end if; end if;
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => Arg_List,
Pragma_Argument_Associations => Arg_List, Pragma_Name => P_Name);
Pragma_Identifier =>
Make_Identifier (Loc, P_Name));
end; end;
-- The following three aspects can be specified for a -- CPU, Interrupt_Priority, Priority
-- subprogram body, in which case we generate pragmas for them
-- and insert them ahead of local declarations, rather than -- These three aspects can be specified for a subprogram body,
-- after the body. -- in which case we generate pragmas for them and insert them
-- ahead of local declarations, rather than after the body.
when Aspect_CPU | when Aspect_CPU |
Aspect_Interrupt_Priority | Aspect_Interrupt_Priority |
Aspect_Priority => Aspect_Priority =>
if Nkind (N) = N_Subprogram_Body then if Nkind (N) = N_Subprogram_Body then
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Expr),
Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))),
Expression => Relocate_Node (Expr))), Pragma_Name => Chars (Id));
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
else else
Aitem := Aitem :=
Make_Attribute_Definition_Clause (Loc, Make_Attribute_Definition_Clause (Loc,
...@@ -1419,17 +1459,17 @@ package body Sem_Ch13 is ...@@ -1419,17 +1459,17 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr)); Expression => Relocate_Node (Expr));
end if; end if;
-- Warnings
when Aspect_Warnings => when Aspect_Warnings =>
Aitem :=
Make_Pragma (Loc, Make_Aitem_Pragma
Pragma_Argument_Associations => New_List ( (Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr), Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)), Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Loc, Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))), Expression => New_Occurrence_Of (E, Loc))),
Pragma_Identifier => Pragma_Name => Chars (Id));
Make_Identifier (Sloc (Id), Chars (Id)),
Class_Present => Class_Present (Aspect));
-- We don't have to play the delay game here, since the only -- We don't have to play the delay game here, since the only
-- values are ON/OFF which don't get analyzed anyway. -- values are ON/OFF which don't get analyzed anyway.
...@@ -1443,6 +1483,8 @@ package body Sem_Ch13 is ...@@ -1443,6 +1483,8 @@ package body Sem_Ch13 is
-- entity, a second argument that is the expression and a third -- entity, a second argument that is the expression and a third
-- argument that is an appropriate message. -- argument that is an appropriate message.
-- Invariant, Type_Invariant
when Aspect_Invariant | when Aspect_Invariant |
Aspect_Type_Invariant => Aspect_Type_Invariant =>
...@@ -1450,16 +1492,13 @@ package body Sem_Ch13 is ...@@ -1450,16 +1492,13 @@ package body Sem_Ch13 is
-- an invariant must apply to a private type, or appear in -- an invariant must apply to a private type, or appear in
-- the private part of a spec and apply to a completion. -- the private part of a spec and apply to a completion.
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent),
Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent),
Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr),
Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))),
Expression => Relocate_Node (Expr))), Pragma_Name => Name_Invariant);
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Invariant));
-- Add message unless exception messages are suppressed -- Add message unless exception messages are suppressed
...@@ -1482,50 +1521,49 @@ package body Sem_Ch13 is ...@@ -1482,50 +1521,49 @@ package body Sem_Ch13 is
-- Case 2d : Aspects that correspond to a pragma with one -- Case 2d : Aspects that correspond to a pragma with one
-- argument. -- argument.
when Aspect_Abstract_State => -- Abstract_State
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Abstract_State),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
when Aspect_Abstract_State =>
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Abstract_State);
Delay_Required := False; Delay_Required := False;
-- Depends
-- Aspect Depends must be delayed because it mentions names -- Aspect Depends must be delayed because it mentions names
-- of inputs and output that are classified by aspect Global. -- of inputs and output that are classified by aspect Global.
when Aspect_Depends => when Aspect_Depends =>
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Identifier => Make_Pragma_Argument_Association (Loc,
Make_Identifier (Sloc (Id), Name_Depends), Expression => Relocate_Node (Expr))),
Pragma_Argument_Associations => New_List ( Pragma_Name => Name_Depends);
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr)))); -- Global
-- Aspect Global must be delayed because it can mention names -- Aspect Global must be delayed because it can mention names
-- and benefit from the forward visibility rules applicable to -- and benefit from the forward visibility rules applicable to
-- aspects of subprograms. -- aspects of subprograms.
when Aspect_Global => when Aspect_Global =>
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Identifier => Make_Pragma_Argument_Association (Loc,
Make_Identifier (Sloc (Id), Name_Global), Expression => Relocate_Node (Expr))),
Pragma_Argument_Associations => New_List ( Pragma_Name => Name_Global);
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr)))); -- Relative_Deadline
when Aspect_Relative_Deadline => when Aspect_Relative_Deadline =>
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc,
Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))),
Expression => Relocate_Node (Expr))), Pragma_Name => Name_Relative_Deadline);
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Relative_Deadline));
-- If the aspect applies to a task, the corresponding pragma -- If the aspect applies to a task, the corresponding pragma
-- must appear within its declarations, not after. -- must appear within its declarations, not after.
...@@ -1562,6 +1600,8 @@ package body Sem_Ch13 is ...@@ -1562,6 +1600,8 @@ package body Sem_Ch13 is
-- Case 3a: The aspects listed below don't correspond to -- Case 3a: The aspects listed below don't correspond to
-- pragmas/attributes but do require delayed analysis. -- pragmas/attributes but do require delayed analysis.
-- Default_Value, Default_Component_Value
when Aspect_Default_Value | when Aspect_Default_Value |
Aspect_Default_Component_Value => Aspect_Default_Component_Value =>
Aitem := Empty; Aitem := Empty;
...@@ -1569,6 +1609,8 @@ package body Sem_Ch13 is ...@@ -1569,6 +1609,8 @@ package body Sem_Ch13 is
-- Case 3b: The aspects listed below don't correspond to -- Case 3b: The aspects listed below don't correspond to
-- pragmas/attributes and don't need delayed analysis. -- pragmas/attributes and don't need delayed analysis.
-- Implicit_Dereference
-- For Implicit_Dereference, External_Name and Link_Name, only -- For Implicit_Dereference, External_Name and Link_Name, only
-- the legality checks are done during the analysis, thus no -- the legality checks are done during the analysis, thus no
-- delay is required. -- delay is required.
...@@ -1577,15 +1619,21 @@ package body Sem_Ch13 is ...@@ -1577,15 +1619,21 @@ package body Sem_Ch13 is
Analyze_Aspect_Implicit_Dereference; Analyze_Aspect_Implicit_Dereference;
goto Continue; goto Continue;
-- External_Name, Link_Name
when Aspect_External_Name | when Aspect_External_Name |
Aspect_Link_Name => Aspect_Link_Name =>
Analyze_Aspect_External_Or_Link_Name; Analyze_Aspect_External_Or_Link_Name;
goto Continue; goto Continue;
-- Dimension
when Aspect_Dimension => when Aspect_Dimension =>
Analyze_Aspect_Dimension (N, Id, Expr); Analyze_Aspect_Dimension (N, Id, Expr);
goto Continue; goto Continue;
-- Dimension_System
when Aspect_Dimension_System => when Aspect_Dimension_System =>
Analyze_Aspect_Dimension_System (N, Id, Expr); Analyze_Aspect_Dimension_System (N, Id, Expr);
goto Continue; goto Continue;
...@@ -1595,6 +1643,8 @@ package body Sem_Ch13 is ...@@ -1595,6 +1643,8 @@ package body Sem_Ch13 is
-- Pre/Post/Test_Case/Contract_Cases whose corresponding -- Pre/Post/Test_Case/Contract_Cases whose corresponding
-- pragmas take care of the delay. -- pragmas take care of the delay.
-- Pre/Post
-- Aspects Pre/Post generate Precondition/Postcondition pragmas -- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second -- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails. -- argument that is an informative message if the test fails.
...@@ -1648,16 +1698,12 @@ package body Sem_Ch13 is ...@@ -1648,16 +1698,12 @@ package body Sem_Ch13 is
-- Build the precondition/postcondition pragma -- Build the precondition/postcondition pragma
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Identifier => Make_Pragma_Argument_Association (Eloc,
Make_Identifier (Sloc (Id), Pname), Chars => Name_Check,
Class_Present => Class_Present (Aspect), Expression => Relocate_Node (Expr))),
Split_PPC => Split_PPC (Aspect), Pragma_Name => Pname);
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Eloc,
Chars => Name_Check,
Expression => Relocate_Node (Expr))));
-- Add message unless exception messages are suppressed -- Add message unless exception messages are suppressed
...@@ -1726,6 +1772,8 @@ package body Sem_Ch13 is ...@@ -1726,6 +1772,8 @@ package body Sem_Ch13 is
goto Continue; goto Continue;
end; end;
-- Test_Case
when Aspect_Test_Case => Test_Case : declare when Aspect_Test_Case => Test_Case : declare
Args : List_Id; Args : List_Id;
Comp_Expr : Node_Id; Comp_Expr : Node_Id;
...@@ -1786,15 +1834,15 @@ package body Sem_Ch13 is ...@@ -1786,15 +1834,15 @@ package body Sem_Ch13 is
-- Build the test-case pragma -- Build the test-case pragma
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => Args,
Pragma_Identifier => Pragma_Name => Nam);
Make_Identifier (Sloc (Id), Nam),
Pragma_Argument_Associations => Args);
Delay_Required := False; Delay_Required := False;
end Test_Case; end Test_Case;
-- Contract_Cases
when Aspect_Contract_Cases => Contract_Cases : declare when Aspect_Contract_Cases => Contract_Cases : declare
Case_Guard : Node_Id; Case_Guard : Node_Id;
Extra : Node_Id; Extra : Node_Id;
...@@ -1860,13 +1908,11 @@ package body Sem_Ch13 is ...@@ -1860,13 +1908,11 @@ package body Sem_Ch13 is
-- Transform the aspect into a pragma -- Transform the aspect into a pragma
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Identifier => Make_Pragma_Argument_Association (Loc,
Make_Identifier (Loc, Nam), Expression => Relocate_Node (Expr))),
Pragma_Argument_Associations => New_List ( Pragma_Name => Nam);
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
Delay_Required := False; Delay_Required := False;
end Contract_Cases; end Contract_Cases;
...@@ -1875,8 +1921,10 @@ package body Sem_Ch13 is ...@@ -1875,8 +1921,10 @@ package body Sem_Ch13 is
-- boolean argument. -- boolean argument.
-- In the general case, the corresponding pragma cannot be -- In the general case, the corresponding pragma cannot be
-- generated yet because the evaluation of the boolean needs to -- generated yet because the evaluation of the boolean needs
-- be delayed til the freeze point. -- to be delayed till the freeze point.
-- Boolwn_Aspects
when Boolean_Aspects | when Boolean_Aspects |
Library_Unit_Aspects => Library_Unit_Aspects =>
...@@ -1954,13 +2002,11 @@ package body Sem_Ch13 is ...@@ -1954,13 +2002,11 @@ package body Sem_Ch13 is
-- simply insert the pragma, no delay is required. -- simply insert the pragma, no delay is required.
if No (Expr) then if No (Expr) then
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent),
Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent)),
Expression => Ent)), Pragma_Name => Chars (Id));
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Delay_Required := False; Delay_Required := False;
...@@ -1979,8 +2025,16 @@ package body Sem_Ch13 is ...@@ -1979,8 +2025,16 @@ package body Sem_Ch13 is
if Present (Aitem) then if Present (Aitem) then
Set_From_Aspect_Specification (Aitem, True); Set_From_Aspect_Specification (Aitem, True);
-- For a pragma, keep pointer to aspect
if Nkind (Aitem) = N_Pragma then if Nkind (Aitem) = N_Pragma then
Set_Corresponding_Aspect (Aitem, Aspect); Set_Corresponding_Aspect (Aitem, Aspect);
-- Also set Is_Ignored flag. No need to set Is_Disabled.
-- We checked that right away, and would not get here.
Set_Is_Ignored (Aitem, Is_Ignored (Aspect));
pragma Assert (not Is_Disabled (Aspect));
end if; end if;
end if; end if;
...@@ -2000,9 +2054,9 @@ package body Sem_Ch13 is ...@@ -2000,9 +2054,9 @@ package body Sem_Ch13 is
goto Continue; goto Continue;
-- In the context of a compilation unit, we directly put the -- In the context of a compilation unit, we directly put the
-- pragma in the Pragmas_After list of the -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
-- N_Compilation_Unit_Aux node (no delay is required here) -- node (no delay is required here) except for aspects on a
-- except for aspects on a subprogram body (see below). -- subprogram body (see below).
elsif Nkind (Parent (N)) = N_Compilation_Unit elsif Nkind (Parent (N)) = N_Compilation_Unit
and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
...@@ -2018,13 +2072,11 @@ package body Sem_Ch13 is ...@@ -2018,13 +2072,11 @@ package body Sem_Ch13 is
if Is_Boolean_Aspect (Aspect) and then No (Aitem) then if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
if Is_True (Static_Boolean (Expr)) then if Is_True (Static_Boolean (Expr)) then
Aitem := Make_Aitem_Pragma
Make_Pragma (Loc, (Pragma_Argument_Associations => New_List (
Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent),
Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent)),
Expression => Ent)), Pragma_Name => Chars (Id));
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Set_From_Aspect_Specification (Aitem, True); Set_From_Aspect_Specification (Aitem, True);
Set_Corresponding_Aspect (Aitem, Aspect); Set_Corresponding_Aspect (Aitem, Aspect);
...@@ -2097,7 +2149,7 @@ package body Sem_Ch13 is ...@@ -2097,7 +2149,7 @@ package body Sem_Ch13 is
Insert_After (Ins_Node, Aitem); Insert_After (Ins_Node, Aitem);
Ins_Node := Aitem; Ins_Node := Aitem;
end if; end if;
end; end Analyze_One_Aspect;
<<Continue>> <<Continue>>
Next (Aspect); Next (Aspect);
......
gcc/ada/sem_ch6.adb
...@@ -12082,16 +12082,12 @@ package body Sem_Ch6 is ...@@ -12082,16 +12082,12 @@ package body Sem_Ch6 is
declare declare
New_Expr : constant Node_Id := New_Expr : constant Node_Id :=
Get_Pragma_Arg Get_Pragma_Arg
(Next (Next (First (Pragma_Argument_Associations
(First (Inherited_Precond))));
(Pragma_Argument_Associations
(Inherited_Precond))));
Old_Expr : constant Node_Id := Old_Expr : constant Node_Id :=
Get_Pragma_Arg Get_Pragma_Arg
(Next (Next (First (Pragma_Argument_Associations
(First
(Pragma_Argument_Associations
(Precond)))); (Precond))));
begin begin
...@@ -12404,8 +12400,7 @@ package body Sem_Ch6 is ...@@ -12404,8 +12400,7 @@ package body Sem_Ch6 is
declare declare
Post_Proc : constant Entity_Id := Post_Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc, Chars => Name_uPostconditions);
Chars => Name_uPostconditions);
-- The entity for the _Postconditions procedure -- The entity for the _Postconditions procedure
begin begin
......
gcc/ada/sem_prag.adb
...@@ -2138,12 +2138,7 @@ package body Sem_Prag is ...@@ -2138,12 +2138,7 @@ package body Sem_Prag is
-- For a pragma PPC in the extended main source unit, record enabled -- For a pragma PPC in the extended main source unit, record enabled
-- status in SCO. -- status in SCO.
-- This may seem redundant with the call to Check_Kind test that if not Is_Ignored (N) and then not Split_PPC (N) then
-- occurs later on when the pragma is rewritten into a pragma Check
-- but is actually required in the case of a postcondition within a
-- generic.
if Check_Kind (Pname) = Name_Check and then not Split_PPC (N) then
Set_SCO_Pragma_Enabled (Loc); Set_SCO_Pragma_Enabled (Loc);
end if; end if;
...@@ -6775,14 +6770,20 @@ package body Sem_Prag is ...@@ -6775,14 +6770,20 @@ package body Sem_Prag is
Pname := Chars (Identifier (Corresponding_Aspect (N))); Pname := Chars (Identifier (Corresponding_Aspect (N)));
end if; end if;
Check_Applicable_Policy (N); -- Check applicable policy. We skip this for a pragma that came from
-- an aspect, since we already dealt with the Disable case, and we set
-- the Is_Ignored flag at the time the aspect was analyzed.
-- If pragma is disabled, rewrite as Null statement and skip analysis if not From_Aspect_Specification (N) then
Check_Applicable_Policy (N);
if Is_Disabled (N) then -- If pragma is disabled, rewrite as NULL and skip analysis
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N); if Is_Disabled (N) then
raise Pragma_Exit; Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
end if;
end if; end if;
-- Preset arguments -- Preset arguments
...@@ -8109,26 +8110,37 @@ package body Sem_Prag is ...@@ -8109,26 +8110,37 @@ package body Sem_Prag is
-- Set Check_On to indicate check status -- Set Check_On to indicate check status
case Check_Kind (Cname) is -- If this comes from an aspect, we have already taken care of
when Name_Ignore => -- the policy active when the aspect was analyzed, and Is_Ignore
Check_On := False; -- is set appriately already.
when Name_Check => if From_Aspect_Specification (N) then
Check_On := True; Check_On := not Is_Ignored (N);
-- For disable, rewrite pragma as null statement and skip -- Otherwise check the status right now
-- rest of the analysis of the pragma.
when Name_Disable => else
Rewrite (N, Make_Null_Statement (Loc)); case Check_Kind (Cname) is
Analyze (N); when Name_Ignore =>
raise Pragma_Exit; Check_On := False;
-- No other possibilities when Name_Check =>
Check_On := True;
when others => -- For disable, rewrite pragma as null statement and skip
raise Program_Error; -- rest of the analysis of the pragma.
end case;
when Name_Disable =>
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
-- No other possibilities
when others =>
raise Program_Error;
end case;
end if;
-- If check kind was not Disable, then continue pragma analysis -- If check kind was not Disable, then continue pragma analysis
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment