diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-04-23 11:50:31 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-04-23 11:50:31 +0200 |
commit | 9d5598bf839e572e6262367af623d1e1af91c4a6 (patch) | |
tree | 736488b1564594a20c6544bb39015355c43363c0 /gcc | |
parent | 72267417bd5d1072812339dee3bf426b686f81b6 (diff) | |
download | gcc-9d5598bf839e572e6262367af623d1e1af91c4a6.zip gcc-9d5598bf839e572e6262367af623d1e1af91c4a6.tar.gz gcc-9d5598bf839e572e6262367af623d1e1af91c4a6.tar.bz2 |
[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
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 2 | ||||
-rw-r--r-- | gcc/ada/prj-conf.adb | 6 | ||||
-rw-r--r-- | gcc/ada/prj-conf.ads | 8 | ||||
-rw-r--r-- | gcc/ada/prj-part.adb | 30 | ||||
-rw-r--r-- | gcc/ada/prj-part.ads | 10 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 366 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 17 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 66 |
9 files changed, 325 insertions, 206 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6d114d..b81550c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,31 @@ 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> diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c38b023..03442ac 100644 --- a/gcc/ada/exp_util.adb +++ b/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; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 9ba624c..48241ef 100644 --- a/gcc/ada/prj-conf.adb +++ b/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; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 7154e55..172356f 100644 --- a/gcc/ada/prj-conf.ads +++ b/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; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 5d09dbe..7f617a0 100644 --- a/gcc/ada/prj-part.adb +++ b/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; ----------------------- diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 708142d..438ec9d 100644 --- a/gcc/ada/prj-part.ads +++ b/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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b144411..24970f1 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 68f1d41..43f94e1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 373828e..bacb340 100644 --- a/gcc/ada/sem_prag.adb +++ b/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 |