From 316a0661918aacd3cc0acca417b5390ad1e3d535 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 17:35:25 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Yannick Moy * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_prag.adb, sem.ads, sem_util.adb, sem_util.ads, sem_res.adb, sem_ch2.adb, sem_ch4.adb, sem_ch6.adb, sem_ch11.adb: Add semantic flag In_Pre_Post_Expression to indicate that we are in a precondition or postcondition. This is used in Mark_Non_ALFA_Subprogram (renaming of Mark_Non_ALFA_Subprogram_Body) to decide whether to flag the spec or body of the current subprogram as not in ALFA. 2011-08-02 Fabien Chouteau * impunit.adb: Add Ada.Execution_Time.Interrupts in the Ada2012 package list. * a-extiin.ads: New file. 2011-08-02 Bob Duff * a-direct.adb (Rename): Implement AI05-0231-1. In particular, Rename now raises Name_Error instead of Use_Error in certain cases. The other parts of this AI were already implemented properly. From-SVN: r177187 --- gcc/ada/ChangeLog | 22 +++++++++++++++++++ gcc/ada/a-direct.adb | 19 +++++++++++++--- gcc/ada/impunit.adb | 3 ++- gcc/ada/sem.ads | 10 ++++++++- gcc/ada/sem_ch11.adb | 4 ++-- gcc/ada/sem_ch2.adb | 2 +- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch4.adb | 28 ++++++++++++------------ gcc/ada/sem_ch5.adb | 16 +++++++------- gcc/ada/sem_ch6.adb | 4 ++-- gcc/ada/sem_ch9.adb | 52 ++++++++++++++++++++++---------------------- gcc/ada/sem_prag.adb | 3 +++ gcc/ada/sem_res.adb | 8 +++---- gcc/ada/sem_util.adb | 36 ++++++++++++++++++------------ gcc/ada/sem_util.ads | 9 +++++--- 15 files changed, 138 insertions(+), 80 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cabcec110d3..b74d7a5faf7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2011-08-02 Yannick Moy + + * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_prag.adb, sem.ads, + sem_util.adb, sem_util.ads, sem_res.adb, sem_ch2.adb, sem_ch4.adb, + sem_ch6.adb, sem_ch11.adb: Add semantic flag In_Pre_Post_Expression to + indicate that we are in a precondition or postcondition. This is used in + Mark_Non_ALFA_Subprogram (renaming of Mark_Non_ALFA_Subprogram_Body) to + decide whether to flag the spec or body of the current subprogram as + not in ALFA. + +2011-08-02 Fabien Chouteau + + * impunit.adb: Add Ada.Execution_Time.Interrupts in the Ada2012 package + list. + * a-extiin.ads: New file. + +2011-08-02 Bob Duff + + * a-direct.adb (Rename): Implement AI05-0231-1. In particular, Rename + now raises Name_Error instead of Use_Error in certain cases. The other + parts of this AI were already implemented properly. + 2011-08-02 Vincent Celier * link.c: Only import "auto-host.h" when building the gnattools. diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index e4a2697e063..81b8dd5e860 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -40,6 +40,7 @@ with Ada.Unchecked_Deallocation; with Ada.Characters.Handling; use Ada.Characters.Handling; with System.CRTL; use System.CRTL; +with System.OS_Constants; with System.OS_Lib; use System.OS_Lib; with System.Regexp; use System.Regexp; with System.File_IO; use System.File_IO; @@ -1060,8 +1061,20 @@ package body Ada.Directories is Rename_File (Old_Name, New_Name, Success); if not Success then - raise Use_Error with - "file """ & Old_Name & """ could not be renamed"; + -- AI05-0231-1: Name_Error should be raised in case a directory + -- component of New_Name does not exist (as in New_Name => + -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT + -- also indicate that the Old_Name does not exist, but we already + -- checked for that above. All other errors are Use_Error. + + if Errno = System.OS_Constants.ENOENT then + raise Name_Error with + "file """ & Containing_Directory (New_Name) & """ not found"; + + else + raise Use_Error with + "file """ & Old_Name & """ could not be renamed"; + end if; end if; end if; end Rename; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index e911b0ac22d..65e18428cd8 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2011, 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- -- @@ -513,6 +513,7 @@ package body Impunit is "a-cborma", -- Ada.Containers.Bounded_Ordered_Maps "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets "a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps + "a-extiin", -- Ada.Execution_Time.Interrupts ----------------------------------------- -- GNAT Defined Additions to Ada 20012 -- diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index d84ed26f096..79c5a71d2c3 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -240,6 +240,14 @@ package Sem is -- then Full_Analysis above must be False. You should really regard this as -- a read only flag. + In_Pre_Post_Expression : Boolean := False; + -- Switch to indicate that we are in a precondition or postcondition. The + -- analysis is not expected to process a precondition or a postcondition as + -- a sub-analysis for another precondition or postcondition, so this switch + -- needs not be saved for recursive calls. When this switch is True then + -- In_Spec_Expression above must be True also. You should really regard + -- this as a read only flag. + In_Deleted_Code : Boolean := False; -- If the condition in an if-statement is statically known, the branch -- that is not taken is analyzed with expansion disabled, and the tree diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 4f241127250..48ffe4a5468 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -443,7 +443,7 @@ package body Sem_Ch11 is P : Node_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("raise statement is not allowed", N); Check_Unreachable_Code (N); @@ -611,7 +611,7 @@ package body Sem_Ch11 is -- Start of processing for Analyze_Raise_xxx_Error begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("raise statement is not allowed", N); if No (Etype (N)) then diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index 38003e22262..f2c915b06aa 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -81,7 +81,7 @@ package body Sem_Ch2 is and then Is_Object (Entity (N)) and then not Is_In_ALFA (Entity (N)) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; end if; end if; end Analyze_Identifier; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2f5bb0244c8..79a0828603d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3036,7 +3036,7 @@ package body Sem_Ch3 is if Is_In_ALFA (T) and then not Aliased_Present (N) then Set_Is_In_ALFA (Id); else - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; end if; -- These checks should be performed before the initialization expression diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 47a43dd4401..ba631fbffc3 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -350,7 +350,7 @@ package body Sem_Ch4 is procedure Analyze_Aggregate (N : Node_Id) is begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if No (Etype (N)) then Set_Etype (N, Any_Composite); @@ -371,7 +371,7 @@ package body Sem_Ch4 is C : Node_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("allocator is not allowed", N); -- Deal with allocator restrictions @@ -991,7 +991,7 @@ package body Sem_Ch4 is if not Is_Subprogram (Nam_Ent) or else not Is_In_ALFA (Nam_Ent) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; end if; Analyze_One_Call (N, Nam_Ent, True, Success); @@ -1370,7 +1370,7 @@ package body Sem_Ch4 is L : Node_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Candidate_Type := Empty; @@ -1520,7 +1520,7 @@ package body Sem_Ch4 is return; end if; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("conditional expression is not allowed", N); Else_Expr := Next (Then_Expr); @@ -1721,7 +1721,7 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Explicit_Dereference begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("explicit dereference is not allowed", N); Analyze (P); @@ -2483,7 +2483,7 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Membership_Op begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Analyze_Expression (L); @@ -2606,7 +2606,7 @@ package body Sem_Ch4 is procedure Analyze_Null (N : Node_Id) is begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("null is not allowed", N); Set_Etype (N, Any_Access); @@ -3235,7 +3235,7 @@ package body Sem_Ch4 is T : Entity_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Analyze_Expression (Expr); @@ -3295,7 +3295,7 @@ package body Sem_Ch4 is Iterator : Node_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("quantified expression is not allowed", N); Set_Etype (Ent, Standard_Void_Type); @@ -3461,7 +3461,7 @@ package body Sem_Ch4 is Acc_Type : Entity_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Analyze (P); @@ -4326,7 +4326,7 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Slice begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("slice is not allowed", N); Analyze (P); @@ -4371,7 +4371,7 @@ package body Sem_Ch4 is T : Entity_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- If Conversion_OK is set, then the Etype is already set, and the -- only processing required is to analyze the expression. This is @@ -4503,7 +4503,7 @@ package body Sem_Ch4 is procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Find_Type (Subtype_Mark (N)); Analyze_Expression (Expression (N)); Set_Etype (N, Entity (Subtype_Mark (N))); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 5370f701a8a..6283207cc51 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1113,7 +1113,7 @@ package body Sem_Ch5 is if Others_Present and then List_Length (Alternatives (N)) = 1 then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("OTHERS as unique case alternative is not allowed", N); end if; @@ -1195,7 +1195,7 @@ package body Sem_Ch5 is else if Has_Loop_In_Inner_Open_Scopes (U_Name) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("exit label must name the closest enclosing loop", N); end if; @@ -1242,14 +1242,14 @@ package body Sem_Ch5 is if Present (Cond) then if Nkind (Parent (N)) /= N_Loop_Statement then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("exit with when clause must be directly in loop", N); end if; else if Nkind (Parent (N)) /= N_If_Statement then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Nkind (Parent (N)) = N_Elsif_Part then Check_SPARK_Restriction ("exit must be in IF without ELSIF", N); @@ -1258,7 +1258,7 @@ package body Sem_Ch5 is end if; elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("exit must be in IF directly in loop", N); @@ -1266,14 +1266,14 @@ package body Sem_Ch5 is -- leads to an error mentioning the ELSE. elsif Present (Else_Statements (Parent (N))) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("exit must be in IF without ELSE", N); -- An exit in an ELSIF does not reach here, as it would have been -- detected in the case (Nkind (Parent (N)) /= N_If_Statement). elsif Present (Elsif_Parts (Parent (N))) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("exit must be in IF without ELSIF", N); end if; end if; @@ -1302,7 +1302,7 @@ package body Sem_Ch5 is Label_Ent : Entity_Id; begin - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("goto statement is not allowed", N); -- Actual semantic checks diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d02ac62324c..99ba2a23af2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -638,13 +638,13 @@ package body Sem_Ch6 is (Nkind (Parent (Parent (N))) /= N_Subprogram_Body or else Present (Next (N))) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("RETURN should be the last statement in function", N); end if; else - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("extended RETURN is not allowed", N); -- Analyze parts specific to extended_return_statement: diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 2a2c6c55223..f535f7e331d 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -101,7 +101,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("abort statement is not allowed", N); T_Name := First (Names (N)); @@ -140,7 +140,7 @@ package body Sem_Ch9 is procedure Analyze_Accept_Alternative (N : Node_Id) is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); @@ -174,7 +174,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("accept statement is not allowed", N); -- Entry name is initialized to Any_Id. It should get reset to the @@ -406,7 +406,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("select statement is not allowed", N); Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); @@ -453,7 +453,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); @@ -500,7 +500,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_Restriction (No_Delay, N); if Present (Pragmas_Before (N)) then @@ -552,7 +552,7 @@ package body Sem_Ch9 is E : constant Node_Id := Expression (N); begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Relative_Delay, N); Check_Restriction (No_Delay, N); @@ -571,7 +571,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); @@ -600,7 +600,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- Entry_Name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset @@ -833,7 +833,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Present (Index) then Analyze (Index); @@ -861,7 +861,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("entry call is not allowed", N); if Present (Pragmas_Before (N)) then @@ -897,7 +897,7 @@ package body Sem_Ch9 is begin Generate_Definition (Def_Id); Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- Case of no discrete subtype definition @@ -967,7 +967,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Analyze (Def); -- There is no elaboration of the entry index specification. Therefore, @@ -1009,7 +1009,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Set_Ekind (Body_Id, E_Protected_Body); Spec_Id := Find_Concurrent_Spec (Body_Id); @@ -1128,7 +1128,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("protected definition is not allowed", N); Analyze_Declarations (Visible_Declarations (N)); @@ -1182,7 +1182,7 @@ package body Sem_Ch9 is end if; Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_Restriction (No_Protected_Types, N); T := Find_Type_Name (N); @@ -1324,7 +1324,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("requeue statement is not allowed", N); Check_Restriction (No_Requeue_Statements, N); Check_Unreachable_Code (N); @@ -1599,7 +1599,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); @@ -1720,7 +1720,7 @@ package body Sem_Ch9 is begin Generate_Definition (Id); Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- The node is rewritten as a protected type declaration, in exact -- analogy with what is done with single tasks. @@ -1782,7 +1782,7 @@ package body Sem_Ch9 is begin Generate_Definition (Id); Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- The node is rewritten as a task type declaration, followed by an -- object declaration of that anonymous task type. @@ -1860,7 +1860,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Set_Ekind (Body_Id, E_Task_Body); Set_Scope (Body_Id, Current_Scope); Spec_Id := Find_Concurrent_Spec (Body_Id); @@ -1981,7 +1981,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("task definition is not allowed", N); if Present (Visible_Declarations (N)) then @@ -2016,7 +2016,7 @@ package body Sem_Ch9 is begin Check_Restriction (No_Tasking, N); Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; T := Find_Type_Name (N); Generate_Definition (T); @@ -2122,7 +2122,7 @@ package body Sem_Ch9 is procedure Analyze_Terminate_Alternative (N : Node_Id) is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); @@ -2144,7 +2144,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); @@ -2181,7 +2181,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 01d6aee5869..20b63b8ccfa 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -253,8 +253,11 @@ package body Sem_Prag is -- Preanalyze the boolean expression, we treat this as a spec expression -- (i.e. similar to a default expression). + pragma Assert (In_Pre_Post_Expression = False); + In_Pre_Post_Expression := True; Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + In_Pre_Post_Expression := False; -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index faf20d637f4..840537d8377 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5964,12 +5964,12 @@ package body Sem_Res is -- types or array types except String. if Is_Boolean_Type (T) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; Check_SPARK_Restriction ("comparison is not defined on Boolean type", N); elsif Is_Array_Type (T) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; if Base_Type (T) /= Standard_String then Check_SPARK_Restriction @@ -6828,7 +6828,7 @@ package body Sem_Res is -- operands have equal static bounds. if Is_Array_Type (T) then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; -- Protect call to Matching_Static_Array_Bounds to avoid costly -- operation if not needed. @@ -7378,7 +7378,7 @@ package body Sem_Res is if Is_Array_Type (B_Typ) and then Nkind (N) in N_Binary_Op then - Mark_Non_ALFA_Subprogram_Body; + Mark_Non_ALFA_Subprogram; declare Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 397784676de..a9a9100b504 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -141,7 +141,7 @@ package body Sem_Util is -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. - procedure Mark_Non_ALFA_Subprogram_Body_Unconditional; + procedure Mark_Non_ALFA_Subprogram_Unconditional; -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the -- latter to be small and inlined. @@ -2315,34 +2315,42 @@ package body Sem_Util is end if; end Current_Subprogram; - ----------------------------------- - -- Mark_Non_ALFA_Subprogram_Body -- - ----------------------------------- + ------------------------------ + -- Mark_Non_ALFA_Subprogram -- + ------------------------------ - procedure Mark_Non_ALFA_Subprogram_Body is + procedure Mark_Non_ALFA_Subprogram is begin -- Isolate marking of the current subprogram body so that the body of - -- Mark_Non_ALFA_Subprogram_Body is small and inlined. + -- Mark_Non_ALFA_Subprogram is small and inlined. if ALFA_Mode then - Mark_Non_ALFA_Subprogram_Body_Unconditional; + Mark_Non_ALFA_Subprogram_Unconditional; end if; - end Mark_Non_ALFA_Subprogram_Body; + end Mark_Non_ALFA_Subprogram; - ------------------------------------------------- - -- Mark_Non_ALFA_Subprogram_Body_Unconditional -- - ------------------------------------------------- + -------------------------------------------- + -- Mark_Non_ALFA_Subprogram_Unconditional -- + -------------------------------------------- - procedure Mark_Non_ALFA_Subprogram_Body_Unconditional is + procedure Mark_Non_ALFA_Subprogram_Unconditional is Cur_Subp : constant Entity_Id := Current_Subprogram; begin if Present (Cur_Subp) and then (Is_Subprogram (Cur_Subp) or else Is_Generic_Subprogram (Cur_Subp)) then - Set_Body_Is_In_ALFA (Cur_Subp, False); + -- If the non-ALFA construct is in a precondition or postcondition, + -- then mark the subprogram as not in ALFA. Otherwise, mark the + -- subprogram body as not in ALFA. + + if In_Pre_Post_Expression then + Set_Is_In_ALFA (Cur_Subp, False); + else + Set_Body_Is_In_ALFA (Cur_Subp, False); + end if; end if; - end Mark_Non_ALFA_Subprogram_Body_Unconditional; + end Mark_Non_ALFA_Subprogram_Unconditional; --------------------- -- Defining_Entity -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c533b1d054f..938b03100cd 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -277,9 +277,12 @@ package Sem_Util is -- Current_Scope is returned. The returned value is Empty if this is called -- from a library package which is not within any subprogram. - procedure Mark_Non_ALFA_Subprogram_Body; - -- If Current_Subprogram is not Empty, set its flag Body_Is_In_ALFA to - -- False, otherwise do nothing. + procedure Mark_Non_ALFA_Subprogram; + -- If Current_Subprogram is not Empty, mark either its specification or its + -- body as not being in ALFA. If called during the analysis of a + -- precondition or postcondition, as indicated by the flag + -- In_Pre_Post_Expression, mark the specification as not being in ALFA. + -- Otherwise, mark the body as not being in ALFA. function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- 2.30.2