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>
* 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.
2013-04-23 Hristian Kirtchev <kirtchev@adacore.com>
......
gcc/ada/exp_util.adb
......@@ -2586,9 +2586,11 @@ package body Exp_Util is
begin
Start_String;
Internal_Full_Qualified_Name (E);
if Append_NUL then
Store_String_Char (Get_Char_Code (ASCII.NUL));
end if;
return End_String;
end Fully_Qualified_Name_String;
......
gcc/ada/prj-conf.adb
......@@ -1558,7 +1558,8 @@ package body Prj.Conf is
Config_File_Path : out String_Access;
Target_Name : String := "";
Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null)
On_Load_Config : Config_File_Hook := null;
Implicit_Project : Boolean := False)
is
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
......@@ -1578,7 +1579,8 @@ package body Prj.Conf is
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => False,
Env => Env);
Env => Env,
Implicit_Project => Implicit_Project);
if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node;
......
gcc/ada/prj-conf.ads
......@@ -55,7 +55,8 @@ package Prj.Conf is
Config_File_Path : out String_Access;
Target_Name : 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
-- this configuration project.
--
......@@ -85,6 +86,11 @@ package Prj.Conf is
-- Any error in generating or parsing the config file is reported via the
-- Invalid_Config exception, with an appropriate message. Any error while
-- 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
(Main_Project : out Prj.Project_Id;
......
gcc/ada/prj-part.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -191,7 +191,8 @@ package body Prj.Part is
Depth : Natural;
Current_Dir : String;
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
-- 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
......@@ -201,6 +202,10 @@ package body Prj.Part is
--
-- Is_Config_File should be set to True if the project represents a config
-- 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
(In_Tree : Project_Node_Tree_Ref;
......@@ -530,7 +535,8 @@ package body Prj.Part is
Current_Directory : String := "";
Is_Config_File : Boolean;
Env : in out Prj.Tree.Environment;
Target_Name : String := "")
Target_Name : String := "";
Implicit_Project : Boolean := False)
is
Dummy : Boolean;
pragma Warnings (Off, Dummy);
......@@ -598,7 +604,8 @@ package body Prj.Part is
Depth => 0,
Current_Dir => Current_Directory,
Is_Config_File => Is_Config_File,
Env => Env);
Env => Env,
Implicit_Project => Implicit_Project);
exception
when Types.Unrecoverable_Error =>
......@@ -1230,7 +1237,8 @@ package body Prj.Part is
Depth : Natural;
Current_Dir : String;
Is_Config_File : Boolean;
Env : in out Environment)
Env : in out Environment;
Implicit_Project : Boolean := False)
is
Path_Name : constant String := Get_Name_String (Path_Name_Id);
......@@ -1394,7 +1402,10 @@ package body Prj.Part is
Tree.Reset_State;
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
-- following Ada identifier's syntax).
......@@ -1977,6 +1988,13 @@ package body Prj.Part is
Tree.Restore_And_Free (Project_Comment_State);
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;
-----------------------
......
gcc/ada/prj-part.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -47,7 +47,8 @@ package Prj.Part is
Current_Directory : String := "";
Is_Config_File : Boolean;
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.
-- 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,
......@@ -66,5 +67,10 @@ package Prj.Part is
-- Target_Name will be used to initialize the default project path, unless
-- In_Tree.Project_Path has already been initialized (which is the
-- 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;
gcc/ada/sem_ch13.adb
......@@ -961,7 +961,7 @@ package body Sem_Ch13 is
Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop
declare
Analyze_One_Aspect : declare
Expr : constant Node_Id := Expression (Aspect);
Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect);
......@@ -977,12 +977,22 @@ package body Sem_Ch13 is
-- is set below when Expr is present.
procedure Analyze_Aspect_External_Or_Link_Name;
-- This routine performs the analysis of the External_Name or
-- Link_Name aspects.
-- Perform analysis of the External_Name or Link_Name aspects
procedure Analyze_Aspect_Implicit_Dereference;
-- This routine performs the analysis of the Implicit_Dereference
-- aspects.
-- Perform analysis of the Implicit_Dereference 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 --
......@@ -1051,6 +1061,42 @@ package body Sem_Ch13 is
end if;
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
-- Skip aspect if already analyzed (not clear if this is needed)
......@@ -1059,7 +1105,8 @@ package body Sem_Ch13 is
end if;
-- 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);
......@@ -1218,36 +1265,32 @@ package body Sem_Ch13 is
-- referring to the entity, and the second argument is the
-- aspect definition expression.
-- Suppress/Unsuppress
when Aspect_Suppress |
Aspect_Unsuppress =>
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))),
Make_Aitem_Pragma
(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 => Chars (Id));
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
-- Synchronization
-- The aspect corresponds to pragma Implemented. Construct the
-- pragma.
-- Corresponds to pragma Implemented, construct the pragma
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_Identifier (Sloc (Id), Name_Implemented));
Make_Aitem_Pragma
(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
-- | By_Protected_Procedure | By_Any | Optional which don't
......@@ -1255,16 +1298,18 @@ package body Sem_Ch13 is
Delay_Required := False;
-- Attach Handler
when Aspect_Attach_Handler =>
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Attach_Handler),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Attach_Handler);
-- Dynamic_Predicate, Predicate, Static_Predicate
when Aspect_Dynamic_Predicate |
Aspect_Predicate |
......@@ -1274,16 +1319,13 @@ package body Sem_Ch13 is
-- flags recording whether it is static/dynamic). We also
-- set flags recording this in the type itself.
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Predicate));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Predicate);
-- Mark type has predicates, and remember what kind of
-- aspect lead to this predicate (we need this to access
......@@ -1301,9 +1343,7 @@ package body Sem_Ch13 is
-- has a freeze node, because that is the one that will be
-- visible at freeze time.
if Is_Private_Type (E)
and then Present (Full_View (E))
then
if Is_Private_Type (E) and then Present (Full_View (E)) then
Set_Has_Predicates (Full_View (E));
if A_Id = Aspect_Dynamic_Predicate then
......@@ -1321,6 +1361,8 @@ package body Sem_Ch13 is
-- referring to the entity, and the first argument is the
-- aspect definition expression.
-- Convention
when Aspect_Convention =>
-- The aspect may be part of the specification of an import
......@@ -1387,30 +1429,28 @@ package body Sem_Ch13 is
Append_To (Arg_List, E_Assoc);
end if;
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => Arg_List,
Pragma_Identifier =>
Make_Identifier (Loc, P_Name));
Make_Aitem_Pragma
(Pragma_Argument_Associations => Arg_List,
Pragma_Name => P_Name);
end;
-- The following three aspects can be specified for a
-- subprogram body, in which case we generate pragmas for them
-- and insert them ahead of local declarations, rather than
-- after the body.
-- CPU, Interrupt_Priority, Priority
-- These three aspects can be specified for a subprogram body,
-- in which case we generate pragmas for them and insert them
-- ahead of local declarations, rather than after the body.
when Aspect_CPU |
Aspect_Interrupt_Priority |
Aspect_Priority =>
if Nkind (N) = N_Subprogram_Body then
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Chars (Id));
else
Aitem :=
Make_Attribute_Definition_Clause (Loc,
......@@ -1419,17 +1459,17 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr));
end if;
-- Warnings
when Aspect_Warnings =>
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)),
Class_Present => Class_Present (Aspect));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)),
Make_Pragma_Argument_Association (Loc,
Expression => New_Occurrence_Of (E, Loc))),
Pragma_Name => Chars (Id));
-- We don't have to play the delay game here, since the only
-- values are ON/OFF which don't get analyzed anyway.
......@@ -1443,6 +1483,8 @@ package body Sem_Ch13 is
-- entity, a second argument that is the expression and a third
-- argument that is an appropriate message.
-- Invariant, Type_Invariant
when Aspect_Invariant |
Aspect_Type_Invariant =>
......@@ -1450,16 +1492,13 @@ package body Sem_Ch13 is
-- an invariant must apply to a private type, or appear in
-- the private part of a spec and apply to a completion.
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Invariant));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Invariant);
-- Add message unless exception messages are suppressed
......@@ -1482,50 +1521,49 @@ package body Sem_Ch13 is
-- Case 2d : Aspects that correspond to a pragma with one
-- argument.
when Aspect_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))));
-- Abstract_State
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;
-- Depends
-- Aspect Depends must be delayed because it mentions names
-- of inputs and output that are classified by aspect Global.
when Aspect_Depends =>
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Depends),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Depends);
-- Global
-- Aspect Global must be delayed because it can mention names
-- and benefit from the forward visibility rules applicable to
-- aspects of subprograms.
when Aspect_Global =>
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Global),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Global);
-- Relative_Deadline
when Aspect_Relative_Deadline =>
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Relative_Deadline));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Relative_Deadline);
-- If the aspect applies to a task, the corresponding pragma
-- must appear within its declarations, not after.
......@@ -1562,6 +1600,8 @@ package body Sem_Ch13 is
-- Case 3a: The aspects listed below don't correspond to
-- pragmas/attributes but do require delayed analysis.
-- Default_Value, Default_Component_Value
when Aspect_Default_Value |
Aspect_Default_Component_Value =>
Aitem := Empty;
......@@ -1569,6 +1609,8 @@ package body Sem_Ch13 is
-- Case 3b: The aspects listed below don't correspond to
-- pragmas/attributes and don't need delayed analysis.
-- Implicit_Dereference
-- For Implicit_Dereference, External_Name and Link_Name, only
-- the legality checks are done during the analysis, thus no
-- delay is required.
......@@ -1577,15 +1619,21 @@ package body Sem_Ch13 is
Analyze_Aspect_Implicit_Dereference;
goto Continue;
-- External_Name, Link_Name
when Aspect_External_Name |
Aspect_Link_Name =>
Analyze_Aspect_External_Or_Link_Name;
goto Continue;
-- Dimension
when Aspect_Dimension =>
Analyze_Aspect_Dimension (N, Id, Expr);
goto Continue;
-- Dimension_System
when Aspect_Dimension_System =>
Analyze_Aspect_Dimension_System (N, Id, Expr);
goto Continue;
......@@ -1595,6 +1643,8 @@ package body Sem_Ch13 is
-- Pre/Post/Test_Case/Contract_Cases whose corresponding
-- pragmas take care of the delay.
-- Pre/Post
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails.
......@@ -1648,16 +1698,12 @@ package body Sem_Ch13 is
-- Build the precondition/postcondition pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Pname),
Class_Present => Class_Present (Aspect),
Split_PPC => Split_PPC (Aspect),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Eloc,
Chars => Name_Check,
Expression => Relocate_Node (Expr))));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Eloc,
Chars => Name_Check,
Expression => Relocate_Node (Expr))),
Pragma_Name => Pname);
-- Add message unless exception messages are suppressed
......@@ -1726,6 +1772,8 @@ package body Sem_Ch13 is
goto Continue;
end;
-- Test_Case
when Aspect_Test_Case => Test_Case : declare
Args : List_Id;
Comp_Expr : Node_Id;
......@@ -1786,15 +1834,15 @@ package body Sem_Ch13 is
-- Build the test-case pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Nam),
Pragma_Argument_Associations => Args);
Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
Pragma_Name => Nam);
Delay_Required := False;
end Test_Case;
-- Contract_Cases
when Aspect_Contract_Cases => Contract_Cases : declare
Case_Guard : Node_Id;
Extra : Node_Id;
......@@ -1860,13 +1908,11 @@ package body Sem_Ch13 is
-- Transform the aspect into a pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Loc, Nam),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Nam);
Delay_Required := False;
end Contract_Cases;
......@@ -1875,8 +1921,10 @@ package body Sem_Ch13 is
-- boolean argument.
-- In the general case, the corresponding pragma cannot be
-- generated yet because the evaluation of the boolean needs to
-- be delayed til the freeze point.
-- generated yet because the evaluation of the boolean needs
-- to be delayed till the freeze point.
-- Boolwn_Aspects
when Boolean_Aspects |
Library_Unit_Aspects =>
......@@ -1954,13 +2002,11 @@ package body Sem_Ch13 is
-- simply insert the pragma, no delay is required.
if No (Expr) then
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Name => Chars (Id));
Delay_Required := False;
......@@ -1979,8 +2025,16 @@ package body Sem_Ch13 is
if Present (Aitem) then
Set_From_Aspect_Specification (Aitem, True);
-- For a pragma, keep pointer to aspect
if Nkind (Aitem) = N_Pragma then
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;
......@@ -2000,9 +2054,9 @@ package body Sem_Ch13 is
goto Continue;
-- In the context of a compilation unit, we directly put the
-- pragma in the Pragmas_After list of the
-- N_Compilation_Unit_Aux node (no delay is required here)
-- except for aspects on a subprogram body (see below).
-- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux
-- node (no delay is required here) except for aspects on a
-- subprogram body (see below).
elsif Nkind (Parent (N)) = N_Compilation_Unit
and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
......@@ -2018,13 +2072,11 @@ package body Sem_Ch13 is
if Is_Boolean_Aspect (Aspect) and then No (Aitem) then
if Is_True (Static_Boolean (Expr)) then
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Name => Chars (Id));
Set_From_Aspect_Specification (Aitem, True);
Set_Corresponding_Aspect (Aitem, Aspect);
......@@ -2097,7 +2149,7 @@ package body Sem_Ch13 is
Insert_After (Ins_Node, Aitem);
Ins_Node := Aitem;
end if;
end;
end Analyze_One_Aspect;
<<Continue>>
Next (Aspect);
......
gcc/ada/sem_ch6.adb
......@@ -12082,16 +12082,12 @@ package body Sem_Ch6 is
declare
New_Expr : constant Node_Id :=
Get_Pragma_Arg
(Next
(First
(Pragma_Argument_Associations
(Inherited_Precond))));
Get_Pragma_Arg
(Next (First (Pragma_Argument_Associations
(Inherited_Precond))));
Old_Expr : constant Node_Id :=
Get_Pragma_Arg
(Next
(First
(Pragma_Argument_Associations
Get_Pragma_Arg
(Next (First (Pragma_Argument_Associations
(Precond))));
begin
......@@ -12404,8 +12400,7 @@ package body Sem_Ch6 is
declare
Post_Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_uPostconditions);
Make_Defining_Identifier (Loc, Chars => Name_uPostconditions);
-- The entity for the _Postconditions procedure
begin
......
gcc/ada/sem_prag.adb
......@@ -2138,12 +2138,7 @@ package body Sem_Prag is
-- For a pragma PPC in the extended main source unit, record enabled
-- status in SCO.
-- This may seem redundant with the call to Check_Kind test that
-- 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
if not Is_Ignored (N) and then not Split_PPC (N) then
Set_SCO_Pragma_Enabled (Loc);
end if;
......@@ -6775,14 +6770,20 @@ package body Sem_Prag is
Pname := Chars (Identifier (Corresponding_Aspect (N)));
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
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
-- If pragma is disabled, rewrite as NULL and skip analysis
if Is_Disabled (N) then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
end if;
end if;
-- Preset arguments
......@@ -8109,26 +8110,37 @@ package body Sem_Prag is
-- Set Check_On to indicate check status
case Check_Kind (Cname) is
when Name_Ignore =>
Check_On := False;
-- If this comes from an aspect, we have already taken care of
-- the policy active when the aspect was analyzed, and Is_Ignore
-- is set appriately already.
when Name_Check =>
Check_On := True;
if From_Aspect_Specification (N) then
Check_On := not Is_Ignored (N);
-- For disable, rewrite pragma as null statement and skip
-- rest of the analysis of the pragma.
-- Otherwise check the status right now
when Name_Disable =>
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
raise Pragma_Exit;
else
case Check_Kind (Cname) is
when Name_Ignore =>
Check_On := False;
-- No other possibilities
when Name_Check =>
Check_On := True;
when others =>
raise Program_Error;
end case;
-- For disable, rewrite pragma as null statement and skip
-- rest of the analysis of the pragma.
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
......
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