+2011-08-02 Yannick Moy <moy@adacore.com>
+
+ * 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 <chouteau@adacore.com>
+
+ * impunit.adb: Add Ada.Execution_Time.Interrupts in the Ada2012 package
+ list.
+ * a-extiin.ads: New file.
+
+2011-08-02 Bob Duff <duff@adacore.com>
+
+ * 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 <celier@adacore.com>
* link.c: Only import "auto-host.h" when building the gnattools.
-- --
-- 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- --
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;
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;
-- --
-- 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- --
"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 --
-- --
-- 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- --
-- 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
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);
-- 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
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;
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
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);
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
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);
L : Node_Id;
begin
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
Candidate_Type := Empty;
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);
-- 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);
-- Start of processing for Analyze_Membership_Op
begin
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
Analyze_Expression (L);
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);
T : Entity_Id;
begin
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
Analyze_Expression (Expr);
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);
Acc_Type : Entity_Id;
begin
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
Analyze (P);
-- 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);
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
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)));
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;
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;
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);
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);
-- 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;
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
(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:
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));
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));
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
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);
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);
begin
Tasking_Used := True;
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
Check_Restriction (No_Delay, N);
if Present (Pragmas_Before (N)) then
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);
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);
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
begin
Tasking_Used := True;
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
if Present (Index) then
Analyze (Index);
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
begin
Generate_Definition (Def_Id);
Tasking_Used := True;
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
-- Case of no discrete subtype definition
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,
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);
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));
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);
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);
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);
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.
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.
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);
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
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);
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));
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);
begin
Tasking_Used := True;
- Mark_Non_ALFA_Subprogram_Body;
+ Mark_Non_ALFA_Subprogram;
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
-- 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.
-- 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
-- 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.
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));
-- 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.
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 --
-- 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
projects / gcc.git / commitdiff