[Ada] Add annotate aspect, add entity argument to pragma Annotate
An optional final named argument [Entity => local_NAME] is allowed
for pragma Annotate to indicate that the annotation is for a particular
entity, and a corresponding Annotate aspect is introduced.
Given the test program:
1. package AspectAnn is
2.Y : constant Integer := 43;
3.X : Integer;
4.pragma Annotate (Hello, Goodbye, Y, Entity => X);
5.Z : Integer with
6. Annotate => (Hello, Goodbye, Y),
7. Annotate => Hello,
8. Annotate => (Goodbye);
9. end;
Compiling with -gnatG gives:
aspectann_E : short_integer := 0;
package aspectann is
aspectann__y : constant integer := 43;
aspectann__x : integer;
pragma annotate (hello, goodbye, aspectann__y, entity =>
aspectann__x);
aspectann__z : integer
with annotate => (hello, goodbye, y),
annotate => hello,
annotate => goodbye;
pragma annotate (hello, goodbye, aspectann__y, entity =>
aspectann__z);
pragma annotate (hello, entity => aspectann__z);
pragma annotate (goodbye, entity => aspectann__z);
end aspectann;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Robert Dewar
* aspects.ads, aspects.adb: Add entries for aspect Annotate.
* gnat_rm.texi: Document Entity argument for pragma Annotate and
Annotate aspect.
* sem_ch13.adb (Analyze_Aspect_Specification): Add processing
for Annotate aspect.
* sem_prag.adb (Analyze_Pragma, case Annotate): Allow optional
Entity argument at end.
* sinfo.ads (N_Aspect_Specification): Add note on Annotate aspect.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 212728)
+++ gnat_rm.texi(working copy)
@@ -287,6 +287,7 @@
Implementation Defined Aspects
* Aspect Abstract_State::
+* Aspect Annotate::
* Aspect Async_Readers::
* Aspect Async_Writers::
* Aspect Contract_Cases::
@@ -1343,7 +1344,7 @@
@noindent
Syntax:
@smallexample @c ada
-pragma Annotate (IDENTIFIER [,IDENTIFIER @{, ARG@}]);
+pragma Annotate (IDENTIFIER [,IDENTIFIER @{, ARG@}] [entity => local_NAME]);
ARG ::= NAME | EXPRESSION
@end smallexample
@@ -1359,7 +1360,8 @@
@code{Standard.String} or else @code{Wide_String} or @code{Wide_Wide_String}
depending on the character literals they contain.
All other kinds of arguments are analyzed as expressions, and must be
-unambiguous.
+unambiguous. The last argument if present must have the identifier
+@code{Entity} and GNAT verifies that a local name is given.
The analyzed pragma is retained in the tree, but not otherwise processed
by any part of the GNAT compiler, except to generate corresponding note
@@ -7932,6 +7934,7 @@
@menu
* Aspect Abstract_State::
+* Aspect Annotate::
* Aspect Async_Readers::
* Aspect Async_Writers::
* Aspect Contract_Cases::
@@ -7981,6 +7984,24 @@
@noindent
This aspect is equivalent to pragma @code{Abstract_State}.
+@node Aspect Annotate
+@unnumberedsec Annotate
+@findex Annotate
+@noindent
+There are three forms of this aspect (where ID is an identifier,
+and ARG is a general expression).
+
+@table @code
+@item Annotate => ID
+Equivalent to @code{pragma Annotate (ID, Entity => Name);}
+
+@item Annotate => (ID)
+Equivalent to @code{pragma Annotate (ID, Entity => Name);}
+
+@item Annotate => (ID ,ID @{, ARG@})
+Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);}
+@end table
+
@node Aspect Async_Readers
@unnumberedsec Aspect Async_Readers
@findex Async_Readers
Index: sinfo.ads
===
--- sinfo.ads (revision 212731)
+++ sinfo.ads (working copy)
@@ -1966,12 +1966,12 @@
--N_SCIL_Dispatch_Table_Tag_Init node, this is the type being declared).
-- SCIL_Controlling_Tag (Node5-Sem)
- --Present in N_SCIL_Dispatching_Call nodes. References the
- --controlling tag of a dispatching call. This is usually an
- --N_Selected_Component node (for a _tag component), but may
- --be an N_Object_Declaration or N_Parameter_Specification node
- --in some cases (e.g., for a call to a classwide streaming operation
- --or to an instance of Ada.Tags.Generic_Dispatching_Constructor).
+ --Present in N_SCIL_Dispatching_Call nodes. References the controlling
+ --tag of a dispatching call. This is usually an N_Selected_Component
+ --node (for a _tag component), but may be an N_Object_Declaration or
+ --N_Parameter_Specification node in some cases (e.g., for a call to
+ --a classwide streaming operation or a call to an instance of
+ --Ada.Tags.Generic_Dispatching_Constructor).
-- SCIL_Tag_Value (Node5-Sem)
--Present in N_SCIL_Membership_Test nodes. Used to reference the tag
@@ -7069,6 +7069,10 @@
-- ASPECT_DEFINITION ::= NAME | EXPRESSION
+ -- Note that for Annotate, the ASPECT_DEFINITION is a pure positional
+
[Ada] Renaming of intrinsic generic subprograms
This patch allows the renaming and subsequent instantiation of generic
subprograms that are marked Intrinsic, such as the predefined units
Unchecked_Conversion and Unchecked_Deallocation.
The following must execute quietly:
gnatmake -q -gnatws uncrename.adb
uncrename
---
with Mumble;
with Dumble;
procedure UncRename is
function Cast is new Mumble (Boolean, Integer);
X : Boolean := True;
Y : Integer := Cast (X);
type A is access all Integer;
procedure Free is new Dumble (Integer, A);
Z : A := new Integer;
begin
Free (Z);
end UncRename;
---
with Ada.Unchecked_Conversion;
generic function Mumble renames Ada.Unchecked_Conversion;
---
with Ada.Unchecked_Deallocation;
generic procedure Dumble renames Ada.Unchecked_Deallocation;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Ed Schonberg
* sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
propagate intrinsic flag to renamed entity, to allow e.g. renaming
of Unchecked_Conversion.
* sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
if the declaration has errors.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 212728)
+++ sem_ch3.adb (working copy)
@@ -2366,11 +2366,14 @@
-- Analyze the contracts of subprogram declarations, subprogram bodies
-- and variables now due to the delayed visibility requirements of their
- -- aspects.
+ -- aspects. Skip analysis if the declaration already has an error.
Decl := First (L);
while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration then
+ if Error_Posted (Decl) then
+null;
+
+ elsif Nkind (Decl) = N_Object_Declaration then
Analyze_Object_Contract (Defining_Entity (Decl));
elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 212726)
+++ sem_ch8.adb (working copy)
@@ -706,6 +706,14 @@
Error_Msg_N ("within its scope, generic denotes its instance", N);
end if;
+ -- For subprograms, propagate the Intrinsic flag, to allow, e.g.
+ -- renamings and subsequent instantiations of Unchecked_Conversion.
+
+ if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then
+Set_Is_Intrinsic_Subprogram
+ (New_P, Is_Intrinsic_Subprogram (Old_P));
+ end if;
+
Check_Library_Unit_Renaming (N, Old_P);
end if;
[Ada] Implement new partition-wide restriction No_Long_Long_Integer
This new restriction No_Long_Long_Integer forbids any explicit reference to type Standard.Long_Long_Integer, and also forbids declaring range types whose implicit base type is Long_Long_Integer, and modular types whose size exceeds Long_Integer'Size. The following is compiled with -gnatl: 1. pragma Restrictions (No_Long_Long_Integer); 2. function NoLLI (m, n : Long_Long_Integer) return Boolean is | >>> violation of restriction "No_Long_Long_Integer" at line 1 3.X : long_Long_Integer := m; | >>> violation of restriction "No_Long_Long_Integer" at line 1 4.type R is range 1 .. Integer'Last + 1; | >>> violation of restriction "No_Long_Long_Integer" at line 1 5.type ROK is range 1 .. Integer'Last; 6.RV : R := 3; 7.type LM is mod 2 ** 33; | >>> violation of restriction "No_Long_Long_Integer" at line 1 8.type LMOK is mod 2 ** 32; 9. begin 10.return X > 3 and then RV > 2; 11. end NoLLI; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Robert Dewar * restrict.ads (Implementation_Restriction): Add No_Long_Long_Integer. * s-rident.ads (Partition_Boolean_Restrictions): Add No_Long_Long_Integer. * sem_ch3.adb (Modular_Type_Declaration): Size must be <= Long_Integer'Size if restriction No_Long_Long_Integer is active. (Signed_Integer_Type_Declaration): Do not allow Long_Long_Integer as the implicit base type for a signed integer type declaration if restriction No_Long_Long_Integer is active. * sem_util.ads, sem_util.adb (Set_Entity_With_Checks): Include check for No_Long_Long_Integer. Index: sem_ch3.adb === --- sem_ch3.adb (revision 212726) +++ sem_ch3.adb (working copy) @@ -17445,6 +17445,10 @@ M_Val := 2 ** System_Max_Binary_Modulus_Power; end if; + if M_Val > 2 ** Standard_Long_Integer_Size then + Check_Restriction (No_Long_Long_Integer, Mod_Expr); + end if; + Set_Modulus (T, M_Val); -- Create bounds for the modular type based on the modulus given in @@ -20622,6 +20626,7 @@ Base_Typ := Base_Type (Standard_Long_Integer); elsif Can_Derive_From (Standard_Long_Long_Integer) then +Check_Restriction (No_Long_Long_Integer, Def); Base_Typ := Base_Type (Standard_Long_Long_Integer); else Index: sem_util.adb === --- sem_util.adb(revision 212723) +++ sem_util.adb(working copy) @@ -15980,6 +15980,10 @@ Check_Restriction (No_Abort_Statements, Post_Node); end if; + if Val = Standard_Long_Long_Integer then + Check_Restriction (No_Long_Long_Integer, Post_Node); + end if; + -- Check for violation of No_Dynamic_Attachment if Restriction_Check_Required (No_Dynamic_Attachment) Index: sem_util.ads === --- sem_util.ads(revision 212721) +++ sem_util.ads(working copy) @@ -1796,6 +1796,9 @@ --If restriction No_Dynamic_Attachment is set, then it checks that the --entity is not one of the restricted names for this restriction. -- + --If restriction No_Long_Long_Integer is set, then it checks that the + --entity is not Standard.Long_Long_Integer. + -- --If restriction No_Implementation_Identifiers is set, then it checks --that the entity is not implementation defined. Index: restrict.ads === --- restrict.ads(revision 212640) +++ restrict.ads(working copy) @@ -72,7 +72,7 @@ -- restriction to the binder. -- The following declarations establish a mapping between restriction - -- identifiers, and the names of corresponding restriction library units. + -- identifiers, and the names of corresponding restricted library units. type Unit_Entry is record Res_Id : Restriction_Id; @@ -129,6 +129,7 @@ No_Implicit_Loops => True, No_Initialize_Scalars => True, No_Local_Protected_Objects => True, + No_Long_Long_Integer => True, No_Protected_Type_Allocators => True, No_Relative_Delay => True, No_Requeue_Statements => True, Index: s-rident.ads === --- s-rident.ads(revision 212640) +++ s-rident.ads(working copy) @@ -124,6 +124,7 @@ No_Local_Allocators, -- (RM H.4(8)) No_Local_Timing_Events,-- (RM D.7(10.2/2)) No_Local_Protected_Objects,
[Ada] Analysis of delayed SPARK aspects and use of SPARK_Mode
This patch clarifies the need of saving and restoring SPARK_Mode in a stack
like fashion. No change in behavior, no test needed.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Hristian Kirtchev
* sem_ch6.adb (Analyze_Subprogram_Body_Contract,
Analyze_Subprogram_Contract): Add comments on SPARK_Mode save/restore.
* sem_ch7.adb (Analyze_Package_Body_Contract,
Analyze_Package_Contract): Add comments on SPARK_Mode save/restore.
Index: sem_ch7.adb
===
--- sem_ch7.adb (revision 212721)
+++ sem_ch7.adb (working copy)
@@ -184,6 +184,11 @@
Prag: Node_Id;
begin
+ -- Due to the timing of contract analysis, delayed pragmas may be
+ -- subject to the wrong SPARK_Mode, usually that of the enclosing
+ -- context. To remedy this, restore the original SPARK_Mode of the
+ -- related package body.
+
Save_SPARK_Mode_And_Set (Body_Id, Mode);
Prag := Get_Pragma (Body_Id, Pragma_Refined_State);
@@ -204,6 +209,9 @@
Error_Msg_N ("package & requires state refinement", Spec_Id);
end if;
+ -- Restore the SPARK_Mode of the enclosing context after all delayed
+ -- pragmas have been analyzed.
+
Restore_SPARK_Mode (Mode);
end Analyze_Package_Body_Contract;
@@ -848,6 +856,11 @@
Prag : Node_Id;
begin
+ -- Due to the timing of contract analysis, delayed pragmas may be
+ -- subject to the wrong SPARK_Mode, usually that of the enclosing
+ -- context. To remedy this, restore the original SPARK_Mode of the
+ -- related package.
+
Save_SPARK_Mode_And_Set (Pack_Id, Mode);
-- Analyze the initialization related pragmas. Initializes must come
@@ -876,6 +889,9 @@
end if;
end if;
+ -- Restore the SPARK_Mode of the enclosing context after all delayed
+ -- pragmas have been analyzed.
+
Restore_SPARK_Mode (Mode);
end Analyze_Package_Contract;
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 212721)
+++ sem_ch6.adb (working copy)
@@ -2040,6 +2040,11 @@
Spec_Id : Entity_Id;
begin
+ -- Due to the timing of contract analysis, delayed pragmas may be
+ -- subject to the wrong SPARK_Mode, usually that of the enclosing
+ -- context. To remedy this, restore the original SPARK_Mode of the
+ -- related subprogram body.
+
Save_SPARK_Mode_And_Set (Body_Id, Mode);
-- When a subprogram body declaration is illegal, its defining entity is
@@ -2116,6 +2121,9 @@
end if;
end if;
+ -- Restore the SPARK_Mode of the enclosing context after all delayed
+ -- pragmas have been analyzed.
+
Restore_SPARK_Mode (Mode);
end Analyze_Subprogram_Body_Contract;
@@ -3693,6 +3701,11 @@
Seen_In_Post : Boolean := False;
begin
+ -- Due to the timing of contract analysis, delayed pragmas may be
+ -- subject to the wrong SPARK_Mode, usually that of the enclosing
+ -- context. To remedy this, restore the original SPARK_Mode of the
+ -- related subprogram body.
+
Save_SPARK_Mode_And_Set (Subp, Mode);
if Present (Items) then
@@ -3817,6 +3830,9 @@
end if;
end if;
+ -- Restore the SPARK_Mode of the enclosing context after all delayed
+ -- pragmas have been analyzed.
+
Restore_SPARK_Mode (Mode);
end Analyze_Subprogram_Contract;
[Ada] Eliminate extra unwanted reads of volatile objects
This corrects a situation in which extra reads of volatile objects was being done. It was detected in the case of validity checks being done on case expressions that were volatile, where two reads were being done, one for the validity check, and one for the actual case selection. But the problem is more general and potentially applies to any situation in which side effects must be executed only once. Consider this example: 1. procedure VolCase (X : Natural) is 2.Y : Natural; 3.pragma Volatile (Y); 4. 5.type R is new Natural; 6.pragma Volatile (R); 7.type APtr is access all R; 8.ARV : APtr := new R'(R(X)); 9.AR : R; 10. 11. begin 12.Y := X; 13.case Y is 14. when 0 => return; 15. when 1 .. Natural'Last => null; 16.end case; 17. 18.case ARV.all is 19. when 0 => return; 20. when 1 .. R'Last => null; 21.end case; 22. 23.AR := ARV.all ** 4; 24. end; The first case at line 13 was handled OK, but the second one at line 18 caused two reads, and additionally the exponentiation at line 23 did multiple reads. Now with this fix, we get the following -gnatG output from this example: Source recreated from tree for Volcase (body) with interfaces; procedure volcase (x : natural) is y : natural; pragma volatile (y); [type volcase__TrB is new integer] freeze volcase__TrB [] type volcase__r is new natural; pragma volatile (volcase__r); type volcase__aptr is access all volcase__r; arv : volcase__aptr := new volcase__r'(volcase__r(x)); ar : volcase__r; begin y := x; R3b : constant natural := y; [constraint_error when not (interfaces__unsigned_32!(R3b) <= 16#7FFF_#) "invalid data"] if R3b = 0 then return; else null; end if; R5b : constant volcase__r := arv.all; [constraint_error when not (interfaces__unsigned_32!(R5b) <= 16#7FFF_#) "invalid data"] if R5b = 0 then return; else null; end if; R7b : constant volcase__r := arv.all; R8b : constant volcase__TrB := do E6b : constant volcase__TrB := R7b * R7b; in E6b * E6b end ; [constraint_error when not (R8b >= 0) "range check failed"] ar := R8b; return; end volcase; And as can be seen from the expanded code, there is only one read of the volatile variable in each of the three cases. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Robert Dewar * checks.adb (Insert_Valid_Check): Don't insist on a name for the prefix when we make calls to Force_Evaluation and Duplicate_Subexpr_No_Checks. * exp_util.adb (Is_Volatile_Reference): Handle all cases properly (Remove_Side_Effects): Handle all volatile references right (Side_Effect_Free): Volatile reference is never side effect free * sinfo.ads (N_Attribute_Reference): Add comments explaining that in the tree, the prefix can be a general expression. Index: exp_util.adb === --- exp_util.adb(revision 212721) +++ exp_util.adb(working copy) @@ -4238,10 +4238,10 @@ -- When a function call appears in Object.Operation format, the -- original representation has two possible forms depending on the -- availability of actual parameters: - -- - --Obj.Func_Call -- N_Selected_Component - --Obj.Func_Call (Param) -- N_Indexed_Component + --Obj.Func_Call N_Selected_Component + --Obj.Func_Call (Param) N_Indexed_Component + else if Nkind (Expr) = N_Indexed_Component then Expr := Prefix (Expr); @@ -5295,18 +5295,34 @@ function Is_Volatile_Reference (N : Node_Id) return Boolean is begin - if Nkind (N) in N_Has_Etype -and then Present (Etype (N)) -and then Treat_As_Volatile (Etype (N)) - then + -- Only source references are to be treated as volatile, internally + -- generated stuff cannot have volatile external effects. + + if not Comes_From_Source (N) then + return False; + + -- Never true for reference to a type + + elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then + return False; + + -- True if object reference with volatile type + + elsif Is_Volatile_Object (N) then return True; + -- True if reference to volatile entity + elsif Is_Entity_Name (N) then return Treat_As_Volatile (Entity (N)); + -- True for slice of volatile array + elsif Nkind (N) = N_Slice then return Is_Volatile_Reference (Prefix (N)); + -- True if volatile component + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then if (Is_Entity_Name (Prefix
[Ada] Missing finalization of a transient class-wide function result
This patch corrects the transient object machinery to treat the renamed result
of a controlled function call as a finalizable transient when the context is an
expression with actions. If this was a different context, the lifetime of the
result would be considered extended and not finalized.
-- Source --
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Limited_Controlled with record
Val : Integer := 0;
end record;
function F1 (Obj : Ctrl) return Integer;
function F2 (Val : Integer) return Ctrl'Class;
procedure Finalize (Obj : in out Ctrl);
procedure Test (Flag : Boolean; Obj : Ctrl);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line ("fin" & Obj.Val'Img);
end Finalize;
function F1 (Obj : Ctrl) return Integer is
begin
return Obj.Val + 1;
end F1;
function F2 (Val : Integer) return Ctrl'Class is
begin
Put_Line ("ini" & Val'Img);
return Ctrl'(Limited_Controlled with Val => Val);
end F2;
procedure Test (Flag : Boolean; Obj : Ctrl) is
begin
if Flag and then F2 (F1 (Obj)).Val = 42 then
raise Program_Error;
end if;
end Test;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
declare
Obj : Ctrl;
begin
Obj.Val := 1;
Test (True, Obj);
exception
when others =>
Put_Line ("ERROR: unexpected exception 1");
end;
declare
Obj : Ctrl;
begin
Obj.Val := 41;
Test (True, Obj);
Put_Line ("ERROR: exception not raised");
exception
when Program_Error =>
null;
when others =>
Put_Line ("ERROR: unexpected exception 2");
end;
end Main;
-- Compilation and output --
$ gnatmake -q main.adb
$ ./main
ini 2
fin 2
fin 1
ini 42
fin 42
fin 41
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Hristian Kirtchev
* exp_util.adb (Is_Aliased): Transient objects
within an expression with actions cannot be considered aliased.
Index: exp_util.adb
===
--- exp_util.adb(revision 212719)
+++ exp_util.adb(working copy)
@@ -4557,6 +4557,15 @@
-- Start of processing for Is_Aliased
begin
+ -- Aliasing in expression with actions does not matter because the
+ -- scope of the transient object is always limited by the scope of
+ -- the EWA. Such objects are always hooked and always finalized at
+ -- the end of the EWA's scope.
+
+ if Nkind (Rel_Node) = N_Expression_With_Actions then
+return False;
+ end if;
+
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration then
@@ -7343,7 +7352,7 @@
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
-N_Object_Declaration
+N_Object_Declaration
and then Is_Finalizable_Transient
(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
[Ada] Analysis of delayed SPARK aspects and use of SPARK_Mode
This patch ensures that all delayed SPARK aspects are analyzed with the proper
SPARK mode of their related construct.
-- Source --
-- modes.ads
package Modes
with SPARK_Mode => On,
Abstract_State => State
is
Var : Integer := 1;
procedure Disabled_1 (Formal : Integer)
with SPARK_Mode => Off,
Global => (Input => (Formal, State, Var)), -- suppressed
Depends => (null => (Formal, Var)); -- suppressed
procedure Enabled_1 (Formal : Integer)
with SPARK_Mode => On,
Global => (Input => (Formal, State, Var)), -- error
Depends => (null => (Formal, Var)); -- error
end Modes;
-- Compilation and output --
$ gcc -c modes.ads
modes.ads:14:33: global item cannot reference parameter of subprogram
modes.ads:14:41: state "State" must appear in at least one input dependence
list
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Hristian Kirtchev
* sem_ch6.adb (Analyze_Subprogram_Body_Contract,
Analyze_Subprogram_Contract): Add new local variable Mode. Save
and restore the SPARK mode of the related construct in a
stack-like fashion.
* sem_ch7.adb (Analyze_Package_Body_Contract,
Analyze_Package_Contract): Add new local variable Mode. Save and
restore the SPARK mode of the related construct in a stack-like fashion.
* sem_util.adb Remove with and use clause for Opt.
(Restore_SPARK_Mode): New routine.
(Save_SPARK_Mode_And_Set): New routine.
* sem_util.ads Add with and use clause for Opt.
(Restore_SPARK_Mode): New routine.
(Save_SPARK_Mode_And_Set): New routine.
Index: sem_ch7.adb
===
--- sem_ch7.adb (revision 212640)
+++ sem_ch7.adb (working copy)
@@ -180,9 +180,12 @@
procedure Analyze_Package_Body_Contract (Body_Id : Entity_Id) is
Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
+ Mode: SPARK_Mode_Type;
Prag: Node_Id;
begin
+ Save_SPARK_Mode_And_Set (Body_Id, Mode);
+
Prag := Get_Pragma (Body_Id, Pragma_Refined_State);
-- The analysis of pragma Refined_State detects whether the spec has
@@ -200,6 +203,8 @@
then
Error_Msg_N ("package & requires state refinement", Spec_Id);
end if;
+
+ Restore_SPARK_Mode (Mode);
end Analyze_Package_Body_Contract;
-
@@ -839,9 +844,12 @@
--
procedure Analyze_Package_Contract (Pack_Id : Entity_Id) is
+ Mode : SPARK_Mode_Type;
Prag : Node_Id;
begin
+ Save_SPARK_Mode_And_Set (Pack_Id, Mode);
+
-- Analyze the initialization related pragmas. Initializes must come
-- before Initial_Condition due to item dependencies.
@@ -867,6 +875,8 @@
Check_Missing_Part_Of (Pack_Id);
end if;
end if;
+
+ Restore_SPARK_Mode (Mode);
end Analyze_Package_Contract;
-
Index: sem_util.adb
===
--- sem_util.adb(revision 212656)
+++ sem_util.adb(working copy)
@@ -41,7 +41,6 @@
with Nlists; use Nlists;
with Nmake;use Nmake;
with Output; use Output;
-with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
@@ -15321,6 +15320,15 @@
Reset_Analyzed (N);
end Reset_Analyzed_Flags;
+
+ -- Restore_SPARK_Mode --
+
+
+ procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
+ begin
+ SPARK_Mode := Mode;
+ end Restore_SPARK_Mode;
+
-- Returns_Unconstrained_Type --
@@ -15624,6 +15632,28 @@
end if;
end Same_Value;
+ -
+ -- Save_SPARK_Mode_And_Set --
+ -
+
+ procedure Save_SPARK_Mode_And_Set
+ (Context : Entity_Id;
+ Mode: out SPARK_Mode_Type)
+ is
+ Prag : constant Node_Id := SPARK_Pragma (Context);
+
+ begin
+ -- Save the current mode in effect
+
+ Mode := SPARK_Mode;
+
+ -- Set the mode of the context as the current SPARK mode
+
+ if Present (Prag) then
+ SPARK_Mode := Get_SPARK_Mode_From_Pragma (Prag);
+ end if;
+ end Save_SPARK_Mode_And_Set;
+
-- Scope_Is_Transient --
Index: sem_util.ads
===
--- sem_util.ads(revision 212640)
+++ sem_util.ads(working copy)
@@ -28,6 +28,7 @@
with Einfo; use Einfo;
with Exp_Tss; use Exp_Tss;
with Namet; use Namet;
+with Opt; use Opt;
with Snames; use Snames;
with Types; u
[Ada] Missing finalization of Object.Operation class-wide interface result
This patch updates the finalization machinery to recognize a case where the
result of a class-wide interface function call with multiple actual parameters
that appears in Object.Operation format requires finalization actions.
-- Source --
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Iface is interface;
type Constructor is tagged null record;
function Make_Any_Iface
(C : in out Constructor;
Val : Natural) return Iface'Class;
type Ctrl is new Controlled and Iface with record
Id : Natural := 0;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 0;
procedure Adjust (Obj : in out Ctrl) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id * 10;
begin
Put_Line (" adj" & Old_Id'Img & " =>" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line (" fin" & Obj.Id'Img);
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Id_Gen := Id_Gen + 1;
Obj.Id := Id_Gen;
Put_Line (" ini" & Obj.Id'Img);
end Initialize;
function Make_Any_Iface
(C : in out Constructor;
Val : Natural) return Iface'Class
is
Result : Ctrl;
begin
return Result;
end Make_Any_Iface;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
Put_Line ("Main start");
declare
C : Constructor;
Obj : Iface'Class := C.Make_Any_Iface (1);
begin
null;
end;
Put_Line ("Main end");
end Main;
-- Compilation and output --
$ gnatmake -q main.adb
$ ./main
Main start
ini 1
adj 1 => 10
fin 1
adj 10 => 100
fin 10
fin 100
Main end
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Hristian Kirtchev
* exp_util.adb (Is_Controlled_Function_Call): Recognize a
controlled function call with multiple actual parameters that
appears in Object.Operation form.
Index: exp_util.adb
===
--- exp_util.adb(revision 212655)
+++ exp_util.adb(working copy)
@@ -4214,7 +4214,8 @@
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
- -- Determine if particular node denotes a controlled function call
+ -- Determine if particular node denotes a controlled function call. The
+ -- call may have been heavily expanded.
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
@@ -4233,12 +4234,22 @@
begin
if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
- end if;
- -- The function call may appear in object.operation format
+ -- When a function call appears in Object.Operation format, the
+ -- original representation has two possible forms depending on the
+ -- availability of actual parameters:
+ --
+ --Obj.Func_Call -- N_Selected_Component
+ --Obj.Func_Call (Param) -- N_Indexed_Component
- if Nkind (Expr) = N_Selected_Component then
-Expr := Selector_Name (Expr);
+ else
+if Nkind (Expr) = N_Indexed_Component then
+ Expr := Prefix (Expr);
+end if;
+
+if Nkind (Expr) = N_Selected_Component then
+ Expr := Selector_Name (Expr);
+end if;
end if;
return
[Ada] Incomplete detection of external tag clash
This change fixes the circuitry responsible for enforcing the uniqueness of 'External_Tag attribute values. Previously uniqueness was checked at type elaboration time only for types that have an explicit External_Tag attribute definition clause. However we must also account for the fact that the default external tag for a type without any such clause may clash with that of a type with an explicit clause that has been elaborated previously. The elaboration of the following unit must cause PROGRAM_ERROR to be raised: $ gnatmake -z -gnatws default_explicit_ext_tag.ads $ ./default_explicit_ext_tag raised PROGRAM_ERROR : duplicated external tag "DEFAULT_EXPLICIT_EXT_TAG.T2" package Default_Explicit_Ext_Tag is type T1 is tagged null record; for T1'External_Tag use "DEFAULT_EXPLICIT_EXT_TAG.T2"; type T2 is tagged null record; end Default_Explicit_Ext_Tag; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Thomas Quinot * exp_disp.adb (Make_DT, Make_VM_TSD): Do not omit Check_TSD call for types that do not have an explicit attribute definition clause for External_Tag, as their default tag may clash with an explicit tag defined for some other type. Index: exp_disp.adb === --- exp_disp.adb(revision 212640) +++ exp_disp.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -6209,9 +6209,8 @@ end if; end if; - -- If the type has a representation clause which specifies its external - -- tag then generate code to check if the external tag of this type is - -- the same as the external tag of some other declaration. + -- Generate code to check if the external tag of this type is the same + -- as the external tag of some other declaration. -- Check_TSD (TSD'Unrestricted_Access); @@ -6226,16 +6225,16 @@ if not No_Run_Time_Mode and then Ada_Version >= Ada_2005 -and then Has_External_Tag_Rep_Clause (Typ) and then RTE_Available (RE_Check_TSD) and then not Debug_Flag_QQ then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc), + Name => + New_Occurrence_Of (RTE (RE_Check_TSD), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), + Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Unchecked_Access; end if; @@ -6810,12 +6809,10 @@ Expressions => TSD_Aggr_List))); -- Generate: - -- Check_TSD - -- (TSD => TSD'Unrestricted_Access); + -- Check_TSD (TSD => TSD'Unrestricted_Access); if Ada_Version >= Ada_2005 and then Is_Library_Level_Entity (Typ) -and then Has_External_Tag_Rep_Clause (Typ) and then RTE_Available (RE_Check_TSD) and then not Debug_Flag_QQ then
[Ada] Failure to unlock shared passive protected
This change addresses a missing unlock operation for the case of a call to a protected function appearing as the expression of a RETURN statement: the unlock was inserted after the statement containing the protected function call, which means that in the case of a RETURN statement it would never be executed. It is now properly generated as a cleanup action that is executed in all cases. The following test case must display '42' without hanging when executed repeatedly: $ gnatmake -q shared_prot_func_ret.adb $ ./shared_prot_func_ret 42 $ ./shared_prot_func_ret 42 package body Session_Db is type Table_Entry is record V, N : Integer; end record; protected Table is procedure Add (Name, Value : Integer); function Find (Name : Integer) return Integer; private T : Table_Entry; end Table; protected body Table is procedure Add (Name, Value : Integer) is begin T := (N => Name, V => Value); end Add; function Find (Name : Integer) return Integer is begin return T.V; end Find; end Table; - -- Add -- - procedure Add (Name : Integer; Value : Integer) is begin Table.Add (Name, Value); end Add; -- -- Find -- -- function Find (Name : Integer) return Integer is begin return Table.Find (Name); end Find; end Session_Db; package Session_Db is pragma Shared_Passive; procedure Add (Name : Integer; Value : Integer); function Find (Name : Integer) return Integer; end Session_Db; with Session_Db; use Session_Db; with Ada.Text_IO; use Ada.Text_IO; procedure Shared_Prot_Func_Ret is begin Session_Db.Add (3, 42); Put_Line (Session_Db.Find (3)'Img); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Thomas Quinot * sem.ads (Scope_Stack_Entry): Reorganize storage of action lists; introduce a new list (cleanup actions) for each (transient) scope. * sinfo.ads, sinfo.adb (Cleanup_Actions): New attribute for N_Block_Statement * exp_ch7.ads (Store_Cleanup_Actions_In_Scope): New subprogram. * exp_ch7.adb (Store_Actions_In_Scope): New subprogram, common processing for Store_xxx_Actions_In_Scope. (Build_Cleanup_Statements): Allow for a list of additional cleanup statements to be passed by the caller. (Expand_Cleanup_Actions): Take custom cleanup actions associated with an N_Block_Statement into account. (Insert_Actions_In_Scope_Around): Account for Scope_Stack_Entry reorganization (refactoring only, no behaviour change). (Make_Transient_Block): Add assertion to ensure that the current scope is indeed a block (namely, the entity for the transient block being constructed syntactically, which has already been established as a scope). If cleanup actions are present in the transient scope, transfer them now to the transient block. * exp_ch6.adb (Expand_Protected_Subprogram_Call): Freeze the called function while it is still present as the name in a call in the tree. This may not be the case later on if the call is rewritten into a transient block. * exp_smem.adb (Add_Shared_Var_Lock_Procs): The post-actions inserted after calling a protected operation on a shared passive protected must be performed in a block finalizer, not just inserted in the tree, so that they are executed even in case of a normal (RETURN) or abnormal (exception) transfer of control outside of the current scope. * exp_smem.ads (Add_Shared_Var_Lock_Procs): Update documentation * sem_ch8.adb, expander.adb, exp_ch11.adb: Adjust for Scope_Stack_Entry reorganization. Index: exp_ch7.adb === --- exp_ch7.adb (revision 212718) +++ exp_ch7.adb (working copy) @@ -150,6 +150,9 @@ -- ??? The entire comment needs to be rewritten -- ??? which entire comment? + procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); + -- Shared processing for Store_xxx_Actions_In_Scope + - -- Finalization Management -- - @@ -296,11 +299,14 @@ -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. - function Build_Cleanup_Statements (N : Node_Id) return List_Id; + function Build_Cleanup_Statements + (N : Node_Id; + Additional_Cleanup : List_Id) return List_Id; -- Create the clean up calls for an asynchronous call block, task master, - -- protected subprogram body, task allocation block or task body. If the - -- context does not contain the above constructs, the routine returns an - -- emp
[Ada] Secondary stack leak for call returning limited discriminated object
This change fixes a defect whereby GNAT would fail to generate secondary stack cleanup code for a scope containing a local object of a limited discriminated type initialized by a (build-in-place) function call, thus causing a storage leak. The following test case must not leak memory for each iteration of the loop: package Limited_Factory is type Lim (D : Integer) is limited private; function Create_In_Place return Lim; private type Lim (D : Integer) is limited record S : String (1 .. 1024); end record; end Limited_Factory; package body Limited_Factory is function Create_In_Place return Lim is begin return Lim'(D => 42, S => (others => 'x')); end; end Limited_Factory; with Limited_Factory; use Limited_Factory; procedure Sec_Stack_BIP is procedure Leak is Obj : Lim := Create_In_Place; begin null; end; begin for J in 1 .. 1000 loop Leak; end loop; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Thomas Quinot * exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped): Start examining the tree at the node passed to Establish_Transient_Scope (not its parent). * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): The access type for the variable storing the reference to the call must be declared and frozen prior to establishing a transient scope. Index: exp_ch7.adb === --- exp_ch7.adb (revision 212716) +++ exp_ch7.adb (working copy) @@ -4208,11 +4208,8 @@ begin The_Parent := N; + P := Empty; loop - P := The_Parent; - pragma Assert (P /= Empty); - The_Parent := Parent (P); - case Nkind (The_Parent) is -- Simple statement can be wrapped @@ -4263,7 +4260,7 @@ -- The expression itself is to be wrapped if its parent is a -- compound statement or any other statement where the expression --- is known to be scalar +-- is known to be scalar. when N_Accept_Alternative | N_Attribute_Definition_Clause | @@ -4279,6 +4276,7 @@ N_If_Statement | N_Iteration_Scheme | N_Terminate_Alternative=> + pragma Assert (Present (P)); return P; when N_Attribute_Reference => @@ -4344,6 +4342,9 @@ when others => null; end case; + + P := The_Parent; + The_Parent := Parent (P); end loop; end Find_Node_To_Be_Wrapped; Index: exp_ch6.adb === --- exp_ch6.adb (revision 212657) +++ exp_ch6.adb (working copy) @@ -10181,10 +10181,9 @@ Func_Call : Node_Id := Function_Call; Function_Id : Entity_Id; Pool_Actual : Node_Id; + Ptr_Typ : Entity_Id; Ptr_Typ_Decl: Node_Id; Pass_Caller_Acc : Boolean := False; - New_Expr: Node_Id; - Ref_Type: Entity_Id; Res_Decl: Node_Id; Result_Subt : Entity_Id; @@ -10224,6 +10223,53 @@ Result_Subt := Etype (Function_Id); + -- Create an access type designating the function's result subtype. We + -- use the type of the original call because it may be a call to an + -- inherited operation, which the expansion has replaced with the parent + -- operation that yields the parent type. Note that this access type + -- must be declared before we establish a transient scope, so that it + -- receives the proper accessibility level. + + Ptr_Typ := Make_Temporary (Loc, 'A'); + Ptr_Typ_Decl := +Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => +Make_Access_To_Object_Definition (Loc, + All_Present=> True, + Subtype_Indication => +New_Occurrence_Of (Etype (Function_Call), Loc))); + + -- The access type and its accompanying object must be inserted after + -- the object declaration in the constrained case, so that the function + -- call can be passed access to the object. In the unconstrained case, + -- or if the object declaration is for a return object, the access type + -- and object must be inserted before the object, since the object + -- declaration is rewritten to be a renaming of a dereference of the + -- access object. Note: we need to freeze Ptr_Typ explicitly, because + -- the result object is in a different (transient) scope, so won't + -- cause freezing. + + if Is_Constrained (Underlying_Type (Result_Subt)) +and then not Is_Return_Object (Defining_Identifier (Object_Decl
[Ada] No usage for an erroneous invocation of a gnat tool
When a gnat tool (gnatbind, gnatclean, gnatchop, gnatfind, gnatls,
gnatname, gnatprep or gnatmake) is incorrectly invoked, the usage is
no longer displayed. Instead, this line is displayed:
type "gnatxxx --help" for help
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Vincent Celier
* gnatchop.adb, make.adb, gnatbind.adb, clean.adb, gprep.adb,
gnatxref.adb, gnatls.adb, gnatfind.adb, gnatname.adb: Do not output
the usage for an erroneous invocation of a gnat tool.
Index: gnatchop.adb
===
--- gnatchop.adb(revision 212640)
+++ gnatchop.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2014, 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- --
@@ -1248,7 +1248,12 @@
-- At least one filename must be given
elsif File.Last = 0 then
- Usage;
+ if Argument_Count = 0 then
+Usage;
+ else
+Put_Line ("type ""gnatchop --help"" for help");
+ end if;
+
return False;
-- No directory given, set directory to null, so that we can just
Index: make.adb
===
--- make.adb(revision 212659)
+++ make.adb(working copy)
@@ -5856,9 +5856,14 @@
Targparm.Get_Target_Parameters;
--- Output usage information if no files to compile
+-- Output usage information if no argument on the command line
-Usage;
+if Argument_Count = 0 then
+ Usage;
+else
+ Write_Line ("type ""gnatmake --help"" for help");
+end if;
+
Finish_Program (Project_Tree, E_Success);
end if;
end if;
Index: gnatbind.adb
===
--- gnatbind.adb(revision 212654)
+++ gnatbind.adb(working copy)
@@ -666,10 +666,15 @@
Display_Version ("GNATBIND", "1995");
end if;
- -- Output usage information if no files
+ -- Output usage information if no arguments
if not More_Lib_Files then
- Bindusg.Display;
+ if Argument_Count = 0 then
+ Bindusg.Display;
+ else
+ Write_Line ("type ""gnatbind --help"" for help");
+ end if;
+
Exit_Program (E_Fatal);
end if;
Index: clean.adb
===
--- clean.adb (revision 212640)
+++ clean.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2014, 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- --
@@ -1460,11 +1460,16 @@
end;
end if;
- -- If neither a project file nor an executable were specified, output
- -- the usage and exit.
+ -- If neither a project file nor an executable were specified, exit
+ -- displaying the usage if there were no arguments on the command line.
if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then
- Usage;
+ if Argument_Count = 0 then
+Usage;
+ else
+Put_Line ("type ""gnatclean --help"" for help");
+ end if;
+
return;
end if;
Index: gprep.adb
===
--- gprep.adb (revision 212640)
+++ gprep.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
--
[Ada] New node kind N_Compound_Statement
This change reorganizes expansion of object initialization statements, which need to be captured under a single node id. Previously these were represented as a (malformed) N_Expression_With_Actions with a NULL statement as its expression. This irregularity is fixed by instead introducing a separate N_Compound_Statement node kind. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-16 Thomas Quinot * sinfo.ads, sinfo.adb (N_Compound_Statement): New node kind. * sem.adb (Analyze): Handle N_Compound_Statement. * sprint.adb (Sprint_Node_Actual): Ditto. * cprint.adb (Cprint_Node): Ditto. * sem_ch5.ads, sem_ch5.adb (Analyze_Compound_Statement): New procedure to handle N_Compound_Statement. * exp_aggr.adb (Collect_Initialization_Statements): Use a proper compound statement node, instead of a bogus expression-with-actions with a NULL statement as its expression, to wrap collected initialization statements. * freeze.ads, freeze.adb (Explode_Initialization_Compound_Statement): New public procedure, lifted from Freeze_Entity. (Freeze_Entity): When freezing an object with captured initialization statements and without delayed freezing, explode compount statement. * sem_ch4.adb (Analyze_Expression_With_Actions): Remove special case that used to handle bogus EWAs with NULL statement as the expression. * exp_ch13.adb (Expand_N_Freeze_Entity): For an object with delayed freezing and captured initialization statements, explode compound statement. Index: sem_ch5.adb === --- sem_ch5.adb (revision 212640) +++ sem_ch5.adb (working copy) @@ -1016,6 +1016,15 @@ end; end Analyze_Block_Statement; + + -- Analyze_Compound_Statement -- + + + procedure Analyze_Compound_Statement (N : Node_Id) is + begin + Analyze_List (Actions (N)); + end Analyze_Compound_Statement; + -- Analyze_Case_Statement -- Index: sem_ch5.ads === --- sem_ch5.ads (revision 212640) +++ sem_ch5.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -30,6 +30,7 @@ procedure Analyze_Assignment (N : Node_Id); procedure Analyze_Block_Statement (N : Node_Id); procedure Analyze_Case_Statement (N : Node_Id); + procedure Analyze_Compound_Statement (N : Node_Id); procedure Analyze_Exit_Statement (N : Node_Id); procedure Analyze_Goto_Statement (N : Node_Id); procedure Analyze_If_Statement (N : Node_Id); Index: sinfo.adb === --- sinfo.adb (revision 212655) +++ sinfo.adb (working copy) @@ -148,6 +148,7 @@ or else NT (N).Nkind = N_And_Then or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux +or else NT (N).Nkind = N_Compound_Statement or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); @@ -3314,6 +3315,7 @@ or else NT (N).Nkind = N_And_Then or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux +or else NT (N).Nkind = N_Compound_Statement or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); Index: sinfo.ads === --- sinfo.ads (revision 212655) +++ sinfo.ads (working copy) @@ -86,6 +86,7 @@ --Add it to the documentation in the appropriate place --Add its fields to this documentation section --Define it in the appropriate classification in Node_Kind + --Add an entry in Is_Syntactic_Field --In the body (sinfo), add entries to the access functions for all -- its fields (except standard expression fields) to include the new -- node in the ch
[Ada] A static predicate can be specified by a Case expression.
This patch completes the implementation of Ada 2012 static predicates, by
adding support for case expressions that can be transformed into a statically
evaluable expression on values of the subtype. Compiling:
gcc -c -gnata test_predicate.adb
must yield:
test_predicate.adb:11:20:
warning: static expression fails static predicate check on "Weekend"
test_predicate.adb:19:25:
warning: static expression fails static predicate check on "French_School"
---
with Text_IO; use Text_IO;
procedure Test_Predicate is
type Days is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
subtype Weekend is Days with Static_Predicate =>
(case Weekend is
when Sat | Sun => True,
when Mon .. Fri => False);
W : Weekend := Tue;
subtype French_School is Days with Static_Predicate =>
(case French_School is
when Mon | Tue => True,
when Wed => False,
when Thu..Fri => True,
when Sat | Sun => False);
J : French_School := Wed;
begin
Put_Line (W'Img);
end Test_Predicate;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Ed Schonberg
* exp_ch4.adb (Expand_N_Case_Expression): Do not expand case
expression if it is the specification of a subtype predicate:
it will be expanded when the return statement is analyzed, or
when a static predicate is transformed into a static expression
for evaluation by the front-end.
* sem_ch13.adb (Get_RList): If the expression for a static
predicate is a case expression, extract the alternatives of the
branches with a True value to create the required statically
evaluable expression.
Index: exp_ch4.adb
===
--- exp_ch4.adb (revision 212648)
+++ exp_ch4.adb (working copy)
@@ -4927,6 +4927,16 @@
return;
end if;
+ -- If the case expression is a predicate specification, do not
+ -- expand, because it will be converted to the proper predicate
+ -- form when building the predicate function.
+
+ if Ekind_In (Current_Scope, E_Function, E_Procedure)
+and then Is_Predicate_Function (Current_Scope)
+ then
+ return;
+ end if;
+
-- We expand
--case X is when A => AX, when B => BX ...
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 212656)
+++ sem_ch13.adb(working copy)
@@ -7584,12 +7584,47 @@
when N_Qualified_Expression =>
return Get_RList (Expression (Exp));
+when N_Case_Expression =>
+declare
+ Alt : Node_Id;
+ Choices : List_Id;
+ Dep : Node_Id;
+
+begin
+ if not Is_Entity_Name (Expression (Expr))
+ or else Etype (Expression (Expr)) /= Typ
+ then
+ Error_Msg_N
+("expression must denaote subtype", Expression (Expr));
+ return False_Range;
+ end if;
+
+ -- Collect discrete choices in all True alternatives
+
+ Choices := New_List;
+ Alt := First (Alternatives (Exp));
+ while Present (Alt) loop
+ Dep := Expression (Alt);
+
+ if not Is_Static_Expression (Dep) then
+ raise Non_Static;
+
+ elsif Is_True (Expr_Value (Dep)) then
+ Append_List_To (Choices,
+ New_Copy_List (Discrete_Choices (Alt)));
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ return Membership_Entries (First (Choices));
+end;
+
-- Expression with actions: if no actions, dig out expression
when N_Expression_With_Actions =>
if Is_Empty_List (Actions (Exp)) then
return Get_RList (Expression (Exp));
-
else
raise Non_Static;
end if;
[Ada] Warning if record size is not a multiple of alignment
This implements a new warning (on by default, controlled
by -gnatw.z/-gnatw.Z, included in -gnatwa), that warns
if a record type has a specified size and alignment where
the size is not a multiple of the alignment resulting in
an object size greater than the specified size.
The warning is suppressed if an explicit value is given
for the object size.
THe following test:
1. package SizeAlign is
2.type R1 is record
3. A,B,C,D,E : Integer;
4.end record;
5.for R1'Size use 5*32;
6.for R1'Alignment use 8;
|
>>> warning: size is not a multiple of alignment for "R1"
>>> warning: size of 160 specified at line 5
>>> warning: Object_Size will be increased to 192
7.
8.type R2 is record
9. A,B,C,D,E : Integer;
10.end record;
11.for R2'Alignment use 8;
12.for R2'Size use 5*32;
|
>>> warning: size is not a multiple of alignment for "R2"
>>> warning: alignment of 8 specified at line 11
>>> warning: Object_Size will be increased to 192
13.
14.type R3 is record
15. A,B,C,D,E : Integer;
16.end record;
17.for R3'Alignment use 8;
18.for R3'Size use 5*32;
19.for R3'Object_Size use 192;
20. end;
generates the given warnings, with the -gnatR2 output of:
Representation information for unit Sizealign (spec)
for R1'Object_Size use 192;
for R1'Value_Size use 160;
for R1'Alignment use 8;
for R1 use record
A at 0 range 0 .. 31;
B at 4 range 0 .. 31;
C at 8 range 0 .. 31;
D at 12 range 0 .. 31;
E at 16 range 0 .. 31;
end record;
for R2'Object_Size use 192;
for R2'Value_Size use 160;
for R2'Alignment use 8;
for R2 use record
A at 0 range 0 .. 31;
B at 4 range 0 .. 31;
C at 8 range 0 .. 31;
D at 12 range 0 .. 31;
E at 16 range 0 .. 31;
end record;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Robert Dewar
* freeze.adb (Freeze_Entity): Warn on incompatible size/alignment.
* gnat_ugn.texi: Document -gnatw.z and -gnatw.Z.
* ug_words: VMS synonyms (WARNINGS=[NO]SIZE_ALIGN) for -gnatw.z/-gnatw.Z
* usage.adb: Add lines for -gnatw.z/-gnatw.Z.
* vms_data.ads: VMS synonyms (WARNINGS=[NO]SIZE_ALIGN) for
-gnatw.z/-gnatw.Z
* warnsw.adb: Set Warn_On_Size_Alignment appropriately.
* warnsw.ads (Warn_On_Size_Alignment): New flag Minor
reformatting.
Index: usage.adb
===
--- usage.adb (revision 212640)
+++ usage.adb (working copy)
@@ -503,7 +503,7 @@
Write_Line ("F* turn off warnings for unreferenced formal");
Write_Line ("g*+ turn on warnings for unrecognized pragma");
Write_Line ("Gturn off warnings for unrecognized pragma");
- Write_Line (".g turn on GNAT warnings, same as Aao.sI.C.V.X");
+ Write_Line (".g turn on GNAT warnings");
Write_Line ("hturn on warnings for hiding declarations");
Write_Line ("H* turn off warnings for hiding declarations");
Write_Line (".h turn on warnings for holes in records");
@@ -589,6 +589,10 @@
"unchecked conversion");
Write_Line ("Zturn off warnings for suspicious " &
"unchecked conversion");
+ Write_Line (".z*+ turn on warnings for record size not a " &
+ "multiple of alignment");
+ Write_Line (".Z turn off warnings for record size not a " &
+ "multiple of alignment");
-- Line for -gnatW switch
Index: ug_words
===
--- ug_words(revision 212640)
+++ ug_words(working copy)
@@ -226,6 +226,8 @@
-gnatw.Y^ /WARNINGS=NOWHY_SPEC_NEEDS_BODY
-gnatwz ^ /WARNINGS=UNCHECKED_CONVERSIONS
-gnatwZ ^ /WARNINGS=NOUNCHECKED_CONVERSIONS
+-gnatw.z^ /WARNINGS=SIZE_ALIGN
+-gnatw.Z^ /WARNINGS=NOSIZE_ALIGN
-gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8
-gnatW? ^ /WIDE_CHARACTER_ENCODING=?
-gnaty ^ /STYLE_CHECKS
Index: gnat_ugn.texi
===
--- gnat_ugn.texi (revision 212654)
+++ gnat_ugn.texi (working copy)
@@ -4798,6 +4798,9 @@
Possible order of elaboration problems
@item
+Size not a multiple of alignment for a record type
+
+@item
Assertions (pragma Assert) that are sure to fail
@item
@@ -5869,6 +5872,28 @@
where the types are known at compile time to have different
sizes or conventions.
+@item -gnatw.z
+@emph{Activate warnings for size not a multiple of alignment.}
+@cindex @option{-gnatw.z} (@command{gcc})
+@cindex Size/Alignment warnings
+T
[Ada] Catch newly illegal case of Unrestricted_Access
It is now illegal to use Unrestricted_Access to directly generate a
thin pointer of an unconstrained array type which references a non-
aliased object. This never worked, and we might as well catch it as
illegal, since it is not hard to do so, as shown in the following
example:
1. with System; use System;
2. procedure SliceUA2 is
3.type A is access all String;
4.for A'Size use Standard'Address_Size;
5.
6.procedure P (Arg : A) is
7.begin
8. null;
9.end P;
10.
11.X : String := "hello world!";
12.X2 : aliased String := "hello world!";
13.
14.AV : A := X'Unrestricted_Access;-- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
15.
16. begin
17.P (X'Unrestricted_Access); -- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
18.P (X(7 .. 12)'Unrestricted_Access); -- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
19.P (X2'Unrestricted_Access); -- OK
20. end;
However we can't catch all cases, so some cases just remain erroneous:
1. with System; use System;
2. procedure SliceUA is
3.type AF is access all String;
4.
5.type A is access all String;
6.for A'Size use Standard'Address_Size;
7.
8.procedure P (Arg : A) is
9.begin
10. if Arg'Length /= 6 then
11. raise Program_Error;
12. end if;
13.end P;
14.
15.X : String := "hello world!";
16.Y : AF := X (7 .. 12)'Unrestricted_Access;
17.
18. begin
19.P (A (Y));
20. end;
Here the conversion in the call on line 19 from a fat pointer to a
thin pointer is erroneous, and executing this program inevitably
raises Program_Error since the bounds get lost in the conversion.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Robert Dewar
* gnat_rm.texi: Document illegal case of Unrestricted_Access.
* sem_attr.adb (Analyze_Access_Attribute): Set_Non_Aliased_Prefix
where it applies.
(Resolve_Attribute, case Access): Flag illegal Unrestricted_Access use.
* sinfo.ads, sinfo.adb (Non_Aliased_Prefix): New flag.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 212654)
+++ gnat_rm.texi(working copy)
@@ -9551,22 +9551,65 @@
It is possible to use @code{Unrestricted_Access} for any type, but care
must be exercised if it is used to create pointers to unconstrained array
-objects. In this case, the resulting pointer has the same scope as the
+objects. In this case, the resulting pointer has the same scope as the
context of the attribute, and may not be returned to some enclosing
-scope. For instance, a function cannot use @code{Unrestricted_Access}
+scope. For instance, a function cannot use @code{Unrestricted_Access}
to create a unconstrained pointer and then return that value to the
-caller. In addition, it is only valid to create pointers to unconstrained
+caller. In addition, it is only valid to create pointers to unconstrained
arrays using this attribute if the pointer has the normal default ``fat''
representation where a pointer has two components, one points to the array
-and one points to the bounds. If a size clause is used to force ``thin''
+and one points to the bounds. If a size clause is used to force ``thin''
representation for a pointer to unconstrained where there is only space for
-a single pointer, then any use of @code{Unrestricted_Access}
-to create a value of such a type (e.g. by conversion from fat to
-thin pointers) is erroneous. Consider the following example:
+a single pointer, then the resulting pointer is not usable.
+In the simple case where a direct use of Unrestricted_Access attempts
+to make a thin pointer for a non-aliased object, the compiler will
+reject the use as illegal, as shown in the following example:
+
@smallexample @c ada
with System; use System;
+procedure SliceUA2 is
+ type A is access all String;
+ for A'Size use Standard'Address_Size;
+
+ procedure P (Arg : A) is
+ begin
+ null;
+ end P;
+
+ X : String := "hello world!";
+ X2 : aliased String := "hello world!";
+
+ AV : A := X'Unrestricted_Access;-- ERROR
+ |
+>>> illegal use of Unrestricted_Access attribute
+>>> attempt to generate thin pointer to unaliased object
+
+begin
+ P (X'Unrestricted_Access); -- ERROR
+ |
+>>> illegal use of Unrestricted_Access attribute
+>>> attempt to generate thin pointer to unaliased object
+
+ P (X(7 .. 12)'Unrestricted_Access); -- ERROR
+ |
+>>> illegal use of Unre
[Ada] Warning match string does not need leading/trailing asterisks
The warning message pattern given for pragma Warning_As_Error or
for pragma Warnings no longer requires leading and trailing asterisks.
The match can be anywhere in the string without these characters
as shown in this example, compiled with -gnatwa -gnatld7 -gnatj55
Compiling: warnmatch.adb
1. pragma Warnings (Off, "never read");
2. pragma Warning_As_Error ("useless");
3. procedure WarnMatch is
4.A : Integer;
5.B : Integer;
6. begin
7.A := 3;
|
>>> error: useless assignment to "A", value
never referenced [warning-as-error]
8. end;
8 lines: No errors, 1 warning (1 treated as errors)
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Robert Dewar
* gnat_rm.texi: Document that leading/trailing asterisks are
now implied for the pattern match string for pragma Warnings
and Warning_As_Error.
* sem_prag.adb (Acquire_Warning_Match_String): New procedure.
(Analyze_Pragma, case Warning_As_Error): Call
Acquire_Warning_Match_String.
(Analyze_Pragma, case Warnings): Call Acquire_Warning_Match_String.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 212650)
+++ gnat_rm.texi(working copy)
@@ -7328,7 +7328,8 @@
@noindent
This pragma signals that the entities whose names are listed are
-deliberately not referenced in the current source unit. This
+deliberately not referenced in the current source unit after the
+occurrence of the pragma. This
suppresses warnings about the
entities being unreferenced, and in addition a warning will be
generated if one of these entities is in fact subsequently referenced in the
@@ -7576,12 +7577,16 @@
The pattern may contain asterisks, which match zero or more characters in
the message. For example, you can use
-@code{pragma Warning_As_Error ("*bits of*unused")} to treat the warning
+@code{pragma Warning_As_Error ("bits of*unused")} to treat the warning
message @code{warning: 960 bits of "a" unused} as an error. No other regular
expression notations are permitted. All characters other than asterisk in
these three specific cases are treated as literal characters in the match.
The match is case insensitive, for example XYZ matches xyz.
+Note that the pattern matches if it occurs anywhere within the warning
+message string (it is not necessary to put an asterisk at the start and
+the end of the message, since this is implied).
+
Another possibility for the static_string_EXPRESSION which works whether
or not error tags are enabled (@option{-gnatw.d}) is to use the
@option{-gnatw} tag string, enclosed in brackets,
@@ -7716,20 +7721,24 @@
The pattern may contain asterisks, which match zero or more characters in
the message. For example, you can use
-@code{pragma Warnings (Off, "*bits of*unused")} to suppress the warning
+@code{pragma Warnings (Off, "bits of*unused")} to suppress the warning
message @code{warning: 960 bits of "a" unused}. No other regular
expression notations are permitted. All characters other than asterisk in
these three specific cases are treated as literal characters in the match.
The match is case insensitive, for example XYZ matches xyz.
+Note that the pattern matches if it occurs anywhere within the warning
+message string (it is not necessary to put an asterisk at the start and
+the end of the message, since this is implied).
+
The above use of patterns to match the message applies only to warning
messages generated by the front end. This form of the pragma with a string
argument can also be used to control warnings provided by the back end and
mentioned above. By using a single full @option{-Wxxx} switch in the pragma,
such warnings can be turned on and off.
-There are two ways to use the pragma in this form. The OFF form can be used as
a
-configuration pragma. The effect is to suppress all warnings (if any)
+There are two ways to use the pragma in this form. The OFF form can be used
+as a configuration pragma. The effect is to suppress all warnings (if any)
that match the pattern string throughout the compilation (or match the
-W switch in the back end case).
Index: sem_prag.adb
===
--- sem_prag.adb(revision 212649)
+++ sem_prag.adb(working copy)
@@ -2781,6 +2781,16 @@
type Args_List is array (Natural range <>) of Node_Id;
-- Types used for arguments to Check_Arg_Order and Gather_Associations
+ ---
+ -- Local Subprograms --
+ ---
+
+ procedure Acquire_Warning_Match_String (Arg : Node_Id);
+ -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
+ -- get the given string argument, and place it in Name_Buffer, adding
+ -- leading and trailing asterisks if they are not already present. The
+ -- caller
[Ada] Enfore SPARK RM rule 7.1.5(2)
This patch modifies the analysis of aspects Abstract_State, Initializes and Initial_Condition to ensure that they are inserted after pragma SPARK_Mode. The proper placement allows for SPARK_Mode to be analyzed first and dictate the mode of the related package. -- Source -- -- initializes_illegal_2.ads package Initializes_Illegal_2 with SPARK_Mode, Initializes=> (S, X), Abstract_State => S is X : Integer; end Initializes_Illegal_2; -- Compilation and output -- $ gcc -c initializes_illegal_2.ads initializes_illegal_2.ads:4:08: aspect "Abstract_State" cannot come after aspect "Initializes" Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-16 Hristian Kirtchev * sem_ch13.adb (Insert_After_SPARK_Mode): Moved to the outer level of routine Analyze_Aspect_Specifications. Ensure that the corresponding pragmas of aspects Initial_Condition and Initializes are inserted after pragma SPARK_Mode. Index: sem_ch13.adb === --- sem_ch13.adb(revision 212640) +++ sem_ch13.adb(working copy) @@ -1158,6 +1158,15 @@ -- Establish the linkages between an aspect and its corresponding -- pragma. Flag Delayed should be set when both constructs are delayed. + procedure Insert_After_SPARK_Mode +(Prag: Node_Id; + Ins_Nod : Node_Id; + Decls : List_Id); + -- Subsidiary to the analysis of aspects Abstract_State, Initializes and + -- Initial_Condition. Insert node Prag before node Ins_Nod. If Ins_Nod + -- denotes pragma SPARK_Mode, then SPARK_Mode is skipped. Decls is the + -- associated declarative list where Prag is to reside. + procedure Insert_Delayed_Pragma (Prag : Node_Id); -- Insert a postcondition-like pragma into the tree depending on the -- context. Prag must denote one of the following: Pre, Post, Depends, @@ -1182,6 +1191,37 @@ Set_Parent(Prag, Asp); end Decorate_Aspect_And_Pragma; + - + -- Insert_After_SPARK_Mode -- + - + + procedure Insert_After_SPARK_Mode +(Prag: Node_Id; + Ins_Nod : Node_Id; + Decls : List_Id) + is + Decl : Node_Id := Ins_Nod; + + begin + -- Skip SPARK_Mode + + if Present (Decl) + and then Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_SPARK_Mode + then +Decl := Next (Decl); + end if; + + if Present (Decl) then +Insert_Before (Decl, Prag); + + -- Aitem acts as the last declaration + + else +Append_To (Decls, Prag); + end if; + end Insert_After_SPARK_Mode; + --- -- Insert_Delayed_Pragma -- --- @@ -2007,51 +2047,10 @@ -- immediately. when Aspect_Abstract_State => Abstract_State : declare - procedure Insert_After_SPARK_Mode -(Ins_Nod : Node_Id; - Decls : List_Id); - -- Insert Aitem before node Ins_Nod. If Ins_Nod denotes - -- pragma SPARK_Mode, then SPARK_Mode is skipped. Decls is - -- the associated declarative list where Aitem is to reside. - - - - -- Insert_After_SPARK_Mode -- - - - - procedure Insert_After_SPARK_Mode -(Ins_Nod : Node_Id; - Decls : List_Id) - is - Decl : Node_Id := Ins_Nod; - - begin - -- Skip SPARK_Mode - - if Present (Decl) - and then Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Name_SPARK_Mode - then -Decl := Next (Decl); - end if; - - if Present (Decl) then -Insert_Before (Decl, Aitem); - - -- Aitem acts as the last declaration - - else -Append_To (Decls, Aitem); - end if; - end Insert_After_SPARK_Mode; - - -- Local variables - Context : Node_Id := N; Decl: Node_Id; Decls : List_Id; - -- Start of processing for Abstract_State - begin -- When aspect Abstract_State appears on a generic package, -- it is propageted to the package instance. The context in @@ -2080,6 +2079,7 @@
[Ada] Missing finalization of a transient class-wide function result
This patch corrects the transient object machinery to treat the renamed result
of a controlled function call as a finalizable transient when the context is an
expression with actions. If this was a different context, the lifetime of the
result would be considered extended and not finalized.
-- Source --
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Limited_Controlled with record
Val : Integer := 0;
end record;
function F1 (Obj : Ctrl) return Integer;
function F2 (Val : Integer) return Ctrl'Class;
procedure Finalize (Obj : in out Ctrl);
procedure Test (Flag : Boolean; Obj : Ctrl);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line ("fin" & Obj.Val'Img);
end Finalize;
function F1 (Obj : Ctrl) return Integer is
begin
return Obj.Val + 1;
end F1;
function F2 (Val : Integer) return Ctrl'Class is
begin
Put_Line ("ini" & Val'Img);
return Ctrl'(Limited_Controlled with Val => Val);
end F2;
procedure Test (Flag : Boolean; Obj : Ctrl) is
begin
if Flag and then F2 (F1 (Obj)).Val = 42 then
raise Program_Error;
end if;
end Test;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
declare
Obj : Ctrl;
begin
Obj.Val := 1;
Test (True, Obj);
exception
when others =>
Put_Line ("ERROR: unexpected exception 1");
end;
declare
Obj : Ctrl;
begin
Obj.Val := 41;
Test (True, Obj);
Put_Line ("ERROR: exception not raised");
exception
when Program_Error =>
null;
when others =>
Put_Line ("ERROR: unexpected exception 2");
end;
end Main;
-- Compilation and output --
$ gnatmake -q main.adb
$ ./main
ini 2
fin 2
fin 1
ini 42
fin 42
fin 41
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Hristian Kirtchev
* exp_ch4.ads, exp_ch4.adb (Find_Hook_Context): Relocated to Exp_Util.
* exp_ch7.adb (Process_Declarations): There is no need to check
that a transient object being hooked is controlled as it would
not have been hooked in the first place.
* exp_ch9.adb Remove with and use clause for Exp_Ch4.
* exp_util.adb (Find_Hook_Context): Relocated from Exp_Ch4.
(Is_Aliased): A renaming of a transient controlled object is
not considered aliasing when it occurs within an expression
with actions.
(Requires_Cleanup_Actions): There is no need to
check that a transient object being hooked is controlled as it
would not have been hooked in the first place.
* exp_util.ads (Find_Hook_Context): Relocated from Exp_Ch4.
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 212640)
+++ exp_ch7.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -1825,8 +1825,6 @@
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
- and then Is_Finalizable_Transient
-(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
Processing_Actions (Has_No_Init => True);
Index: exp_util.adb
===
--- exp_util.adb(revision 212640)
+++ exp_util.adb(working copy)
@@ -2598,6 +2598,145 @@
raise Program_Error;
end Find_Protection_Type;
+ ---
+ -- Find_Hook_Context --
+ ---
+
+ function Find_Hook_Context (N : Node_Id) return Node_Id is
+ Par : Node_Id;
+ Top : Node_Id;
+
+ Wrapped_Node : Node_Id;
+ -- Note: if we are in a transient scope, we want to reuse it as
+ -- the context for actions insertion, if possible. But if N is itself
+ -- part of the stored actions for the current transient scope,
+ -- then we need to insert at the appropriate (inner) location in
+ -- the not as an action on Node
[Ada] Crash on transient classwide limited view on RHS of short-circuit
This change fixes a compiler crash that would occur in some cases where an expression involving transient return values of a limited view of a class-wide interface type occur on the right hand side of a short circuit operator. The following compilation must be accepted quietly: $ gcc -c par-ed.adb limited with Int2; package Int1 is type Int1 is interface; type Ref_Int1 is access Int1'Class; type Ref_Int1_List is array (Positive range <>) of Ref_Int1; function F (This : Int1) return Int2.Int2'Class is abstract; end Int1; package Int2 is type Int2 is interface; function Fullname (This : Int2) return String is abstract; end Int2; with Int1; with Int2; package Par is end; package body Par.Ed is function Find_Toplevel (X : Boolean; Tls : Int1.Ref_Int1_List; Tl : Int1.Int1'Class) return Natural is Res : Natural := 0; use type Int2.Int2'Class; begin for I in Tls'Range loop if X and then Tl.F.Fullname = Tls (I).all.F.Fullname then Res := I; exit; end if; end loop; return Res; end Find_Toplevel; end; package Par.Ed is function Find_Toplevel (X : Boolean; Tls : Int1.Ref_Int1_List; Tl : Int1.Int1'Class) return Natural; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-16 Thomas Quinot * exp_ch4.adb (Find_Hook_Context): New subprogram, extracted from Process_Transient_Oject. * exp_ch4.ads: Ditto. * exp_ch9.adb (Build_Class_Wide_Master): Insert the _master declaration as an action on the topmost enclosing expression, not on a possibly conditional subexpreession. Index: exp_ch9.adb === --- exp_ch9.adb (revision 212640) +++ exp_ch9.adb (working copy) @@ -29,6 +29,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; +with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; @@ -1151,7 +1152,6 @@ then declare Master_Decl : Node_Id; - begin Set_Has_Master_Entity (Master_Scope); @@ -1169,7 +1169,7 @@ Make_Explicit_Dereference (Loc, New_Occurrence_Of (RTE (RE_Current_Master), Loc))); -Insert_Action (Related_Node, Master_Decl); +Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); Analyze (Master_Decl); -- Mark the containing scope as a task master. Masters associated Index: exp_ch4.adb === --- exp_ch4.adb (revision 212640) +++ exp_ch4.adb (working copy) @@ -11390,6 +11390,145 @@ Adjust_Result_Type (N, Typ); end Expand_Short_Circuit_Operator; + --- + -- Find_Hook_Context -- + --- + + function Find_Hook_Context (N : Node_Id) return Node_Id is + Par : Node_Id; + Top : Node_Id; + + Wrapped_Node : Node_Id; + -- Note: if we are in a transient scope, we want to reuse it as + -- the context for actions insertion, if possible. But if N is itself + -- part of the stored actions for the current transient scope, + -- then we need to insert at the appropriate (inner) location in + -- the not as an action on Node_To_Be_Wrapped. + + In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N); + + begin + -- When the node is inside a case/if expression, the lifetime of any + -- temporary controlled object is extended. Find a suitable insertion + -- node by locating the topmost case or if expressions. + + if In_Cond_Expr then + Par := N; + Top := N; + while Present (Par) loop +if Nkind_In (Original_Node (Par), N_Case_Expression, + N_If_Expression) +then + Top := Par; + +-- Prevent the search from going too far + +elsif Is_Body_Or_Package_Declaration (Par) then + exit; +end if; + +Par := Parent (Par); + end loop; + + -- The topmost case or if expression is now recovered, but it may + -- still not be the correct place to add generated code. Climb to + -- find a parent that is part of a declarative or statement list, + -- and is not a list of actuals in a call. + + Par := Top; + while Present (Par) loop +if Is_List_Member (Par) + and then not Nkind_In (Par, N_Component_Association, + N_Discriminant_Association, + N_Parameter_Association, + N_Pragma_Argument_Association) + and then not Nkind_In +
Re: [Ada] PR ada/61505
> 2014-06-14 Bernd Edlinger > > PR ada/61505 > * gnat_rm.texi: Fix errors with makeinfo 5.1. This looks good, except that there's a last change needed (at least according to older versions of makeinfo), now detected: --- gnat_rm.texi(revision 211665) +++ gnat_rm.texi(working copy) @@ -18268,7 +18268,6 @@ * System.Restrictions (s-restri.ads):: * System.Rident (s-rident.ads):: * System.Strings.Stream_Ops (s-ststop.ads):: -* System.Task_Info (s-tasinf.ads):: * System.Unsigned_Types (s-unstyp.ads):: * System.Wch_Cnv (s-wchcnv.ads):: * System.Wch_Con (s-wchcon.ads):: OK with the above additional change, thanks.
[Ada] PR ada/61505
A blind attempt (since I'm using makeinfo 4.8 where the error does not show up) at fixing the makeinfo errors on gnat_rm.texi Let me know if this fixes the errors. 2014-06-14 Arnaud Charlet PR ada/61505 * gnat_rm.texi: Attempt to fix error with makeinfo 5.1 Index: gnat_rm.texi === --- gnat_rm.texi(revision 211623) +++ gnat_rm.texi(working copy) @@ -4104,8 +4104,6 @@ unknown license, and no checking is done. However, standard GNAT headers are recognized, and license information is derived from them as follows. -@itemize @bullet - A GNAT license header starts with a line containing 78 hyphens. The following comment text is searched for the appearance of any of the following strings. @@ -4117,7 +4115,6 @@ ``This specification is adapted from the Ada Semantic Interface'' or ``This specification is derived from the Ada Reference Manual'' is found then the unit is assumed to be unrestricted. -@end itemize @noindent These default actions means that a program with a restricted license pragma
[Ada] Avoid unnecessary warnings about address clause alignment
This patch detects cases where we can tell at compile time that an address clause value is compatible with the alignment of the object so that we do not need to issue a warning. The following is compiled with -gnatwa -gnatld7 -gnatj55 1. pragma Restrictions (No_Exception_Propagation); 2. 3. with System; use System; 4. package Leds is 5.X : Address; 6. 7.type Registers is record 8. A, B, C, D: Integer; 9.end record; 10. 11.GPIOA1 : Registers; 12.for GPIOA1'Address use System'To_Address (16#1000#); 13. 14.GPIOA2 : Registers; 15.for GPIOA2'Address use System'To_Address (16#1001#); | >>> warning: pragma Restrictions (No_Exception_Propagation) in effect, "Program_Error" may result in unhandled exception, address value may be incompatible with alignment of object 16. 17.GPIOA3 : Registers; 18.for GPIOA3'Address use X; | >>> warning: pragma Restrictions (No_Exception_Propagation) in effect, "Program_Error" may result in unhandled exception, address value may be incompatible with alignment of object 19. end Leds; Note that we do NOT issue a warning for line 12 (before this patch, line 12 gets the same warning). Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Robert Dewar * checks.adb: Validate_Alignment_Check_Warnings: New procedure (Apply_Address_Clause_Check): Make Aligment_Warnings table entry. * checks.ads (Alignment_Warnings_Record): New type. (Alignment_Warnings): New table (Validate_Alignment_Check_Warnings): New procedure. * errout.adb (Delete_Warning_And_Continuations): New procedure (Error_Msg_Internal): Set Warning_Msg (Delete_Warning): Handle Warnings_Treated_As_Errors (Finalize): Minor reformatting * errout.ads (Warning_Msg): New variable (Delete_Warning_And_Continuations): New procedure * erroutc.adb (Delete_Msg): Handle Warnings_Treated_As_Errors count. * gnat1drv.adb (Post_Compilation_Validation_Checks): New procedure. Index: checks.adb === --- checks.adb (revision 211623) +++ checks.adb (working copy) @@ -27,15 +27,14 @@ with Casing; use Casing; with Debug;use Debug; with Einfo;use Einfo; -with Errout; use Errout; +with Elists; use Elists; +with Eval_Fat; use Eval_Fat; +with Exp_Ch11; use Exp_Ch11; with Exp_Ch2; use Exp_Ch2; with Exp_Ch4; use Exp_Ch4; -with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; -with Elists; use Elists; with Expander; use Expander; -with Eval_Fat; use Eval_Fat; with Freeze; use Freeze; with Lib; use Lib; with Nlists; use Nlists; @@ -47,9 +46,9 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Eval; use Sem_Eval; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; @@ -589,7 +588,7 @@ Expr : Node_Id; -- Address expression (not necessarily the same as Aexp, for example -- when Aexp is a reference to a constant, in which case Expr gets - -- reset to reference the value expression of the constant. + -- reset to reference the value expression of the constant). procedure Compile_Time_Bad_Alignment; -- Post error warnings when alignment is known to be incompatible. Note @@ -758,21 +757,32 @@ Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Alignment)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - Reason => PE_Misaligned_Address_Value)); + Reason=> PE_Misaligned_Address_Value)); + + Warning_Msg := No_Error_Msg; Analyze (First (Actions (N)), Suppress => All_Checks); - -- If the address clause generates an alignment check and we are - -- in ZFP or some restricted run-time, add a warning to explain - -- the propagation warning that is generated by the check. + -- If the address clause generated a warning message (for example, + -- from Warn_On_Non_Local_Exception mode with the active restriction + -- No_Exception_Propagation). - if Nkind (First (Actions (N))) = N_Raise_Program_Error - and then not Warnings_Off (E) - and then Warn_On_Non_Local_Exception - and then Restriction_Active (No_Exception_Propagation) - then + if Warning_Msg /= No_Error_Msg then + +-- If the expression has a known at compile time value, then +-- once we know the alignment of the type, we can ch
[Ada] Handle range check for float Pre/Succ attributes
In Float_Check_Overflow mode, Succ applied to type'Last or Pred applied to type'First generates a constraint error since the argument is out of range. This was not previously changed, the following test: 1. with Ada.Exceptions; use Ada.Exceptions; 2. with Text_IO; use Text_IO; 3. procedure Bad_Succ is 4.X : Float; 5. begin 6.begin 7. X := Float'Last; 8. X := Float'Succ (X); 9.exception 10. when E : Constraint_Error => 11. Put_Line (Exception_Information (E)); 12.end; 13.begin 14. X := Float'First; 15. X := Float'Pred (X); 16.exception 17. when E : Constraint_Error => 18. Put_Line (Exception_Information (E)); 19.end; 20. end Bad_Succ; Compiled with -gnatc -gnatdt generates a tree file with two occurrences of Do_Range_Check (one on the succ and one on the pred). If this program is executed, the output is: Exception name: CONSTRAINT_ERROR Message: bad_succ.adb:8 range check failed Exception name: CONSTRAINT_ERROR Message: bad_succ.adb:15 range check failed Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Robert Dewar * exp_attr.adb (Expand_N_Attribute_Reference, case Pred): Handle float range check case (Expand_N_Attribute_Reference, case Succ): Handle float range check case. * sem_attr.adb (Analyze_Attribute, case Pred/Succ): Handle float range check case. Index: exp_attr.adb === --- exp_attr.adb(revision 211622) +++ exp_attr.adb(working copy) @@ -4440,7 +4440,8 @@ -- -- 1. Deal with enumeration types with holes - -- 2. For floating-point, generate call to attribute function + -- 2. For floating-point, generate call to attribute function and deal + -- with range checking if Check_Float_Overflow modde. -- 3. For other cases, deal with constraint checking when Attribute_Pred => Pred : @@ -4512,9 +4513,36 @@ Analyze_And_Resolve (N, Typ); -- For floating-point, we transform 'Pred into a call to the Pred - -- floating-point attribute function in Fat_xxx (xxx is root type) + -- floating-point attribute function in Fat_xxx (xxx is root type). elsif Is_Floating_Point_Type (Ptyp) then + +-- Handle case of range check. The Do_Range_Check flag is set only +-- in Check_Float_Overflow mode, and what we need is a specific +-- check against typ'First, since that is the only overflow case. + +declare + Expr : constant Node_Id := First (Exprs); +begin + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + Insert_Action (N, +Make_Raise_Constraint_Error (Loc, + Condition => +Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Expr), + Right_Opnd => +Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => +New_Occurrence_Of (Base_Type (Ptyp), Loc))), + Reason => CE_Range_Check_Failed), + Suppress => All_Checks); + end if; +end; + +-- Transform into call to attribute function + Expand_Fpt_Attribute_R (N); Analyze_And_Resolve (N, Typ); @@ -5563,6 +5591,33 @@ -- floating-point attribute function in Fat_xxx (xxx is root type) elsif Is_Floating_Point_Type (Ptyp) then + +-- Handle case of range check. The Do_Range_Check flag is set only +-- in Check_Float_Overflow mode, and what we need is a specific +-- check against typ'Last, since that is the only overflow case. + +declare + Expr : constant Node_Id := First (Exprs); +begin + if Do_Range_Check (Expr) then + Set_Do_Range_Check (Expr, False); + Insert_Action (N, +Make_Raise_Constraint_Error (Loc, + Condition => +Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr (Expr), + Right_Opnd => +Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => +New_Occurrence_Of (Base_Type (Ptyp), Loc))), + Reason=> CE_Range_Check_Failed), +Suppress => All_Checks); + end if; +end; + +-- Transform in
[Ada] Remove global variable Root_Environment from Project Manager
Global variable Root_Environment was used in the Project Manager, but was not initialized by GNATCOLL and GPS. This patch eliminates the direct use of Root_Environment. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Vincent Celier * makeutl.ads (Compute_Builder_Switches): Change name of parameter Root_Environment to Env. * prj-conf.adb (Check_Switches): Call Locate_Runtime with the Env parameter of procedure Get_Or_Create_Configuration_File. (Locate_Runtime): Call Find_Rts_In_Path with the Project_Path of new parameter Env. * prj-conf.ads (Locate_Runtime): New parameter Env of type Prj.Tree.Environment. Index: make.adb === --- make.adb(revision 211615) +++ make.adb(working copy) @@ -5327,7 +5327,7 @@ if Compute_Builder then Do_Compute_Builder_Switches (Project_Tree => Project_Tree, - Root_Environment => Root_Environment, + Env => Root_Environment, Main_Project => Main_Project, Only_For_Lang=> Name_Ada); Index: makeutl.adb === --- makeutl.adb (revision 211615) +++ makeutl.adb (working copy) @@ -3173,7 +3173,7 @@ procedure Compute_Builder_Switches (Project_Tree: Project_Tree_Ref; - Root_Environment: in out Prj.Tree.Environment; + Env : in out Prj.Tree.Environment; Main_Project: Project_Id; Only_For_Lang : Name_Id := No_Name) is @@ -3312,7 +3312,7 @@ and then Default_Switches_Array /= No_Array then Prj.Err.Error_Msg - (Root_Environment.Flags, + (Env.Flags, "Default_Switches forbidden in presence of " & "Global_Compilation_Switches. Use Switches instead.", Project_Tree.Shared.Arrays.Table @@ -3432,7 +3432,7 @@ Name_Len := Name_Len + Name_Len; Prj.Err.Error_Msg - (Root_Environment.Flags, + (Env.Flags, '"' & Name_Buffer (1 .. Name_Len) & """ is not a builder switch. Consider moving " & "it to Global_Compilation_Switches.", Index: makeutl.ads === --- makeutl.ads (revision 211615) +++ makeutl.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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- -- @@ -323,7 +323,7 @@ procedure Compute_Builder_Switches (Project_Tree : Project_Tree_Ref; - Root_Environment : in out Prj.Tree.Environment; + Env : in out Prj.Tree.Environment; Main_Project : Project_Id; Only_For_Lang: Name_Id := No_Name); -- Compute the builder switches and global compilation switches. Every time Index: prj-conf.adb === --- prj-conf.adb(revision 211615) +++ prj-conf.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- ---Copyright (C) 2006-2013, Free Software Foundation, Inc. -- +--Copyright (C) 2006-2014, 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- -- @@ -721,7 +721,7 @@ Set_Runtime_For (Name_Ada, Name_Buffer (7 .. Name_Len)); - Locate_Runtime (Name_Ada, Project_Tree); + Locate_Runtime (Name_Ada, Project_Tree, Env); end if; elsif Name_Len > 7 @@ -748,7 +748,7 @@ if not Runtime_Name_Set_For (Lang) then
[Ada] Assertion policy and postconditions
This patch fixes the handling of attribute reference 'Old in the presence
of Assertion_Policy (Checked) pragma, when a unit is compiled without the
-gnata flag.
Compiling and executing the following:
gnatmake -q assertion_policy_test.adb
assertion_policy_test
Must yield:
+ Assertion_Policy_Test starts +
Houston we have a problem: Exception name: SYSTEM.ASSERTIONS.ASSERT_FAILURE
Message: failed precondition from advanced_stacks.ads:31
while if the configuration pragma in advanced_stacks.ads is set to Ignore,
the output must be:
+ Assertion_Policy_Test starts +
Houston we have a problem: Exception name: CONSTRAINT_ERROR
Message: advanced_stacks.adb:13 index check failed
---
-- assertion_policy_test.adb
with Ada.Text_Io;
with Ada.Exceptions; use Ada;
with Advanced_Stacks;
procedure Assertion_Policy_Test is
use Ada;
use Text_Io;
Stack_Size : constant := 10;
Test_Stack : Advanced_Stacks.Stack (Stack_Size);
Result : Advanced_Stacks.Element := Advanced_Stacks.Element'First;
begin
Put_Line ("+ Assertion_Policy_Test starts +");
Result := Advanced_Stacks.Pop (Test_Stack);
Put_Line ("+ Assertion_Policy_Test ends +");
exception
when Err : others =>
Put_Line ("Houston we have a problem: " &
Exceptions.Exception_Information(Err));
end Assertion_Policy_Test;
---
-- advanced_stacks.ads
pragma Assertion_Policy (Check);
package Advanced_Stacks is
subtype Element is Integer;
type Vector is array (Positive range <>) of Element;
type Stack (Max_Length : Natural) is
record
Length : Natural := Natural'First;
Data : Vector (1 .. Max_Length);
end record;
function Not_Empty (S : Stack) return Boolean is
(S.Length > 0 and S.Length <= S.Max_Length);
function Not_Full (S : Stack) return Boolean is
(S.Length < S.Max_Length);
procedure Push (E : Element; S: in out Stack)
with Pre => Not_Full(S), -- Precodition
Post => -- Postcondition
(S.Length = S'Old.Length + 1) and then
(S.Data (S.Length) = E) and then
(for all J in 1 .. S'Old.Length =>
S.Data(J) = S'Old.Data(J));
function Pop (S : in out Stack) return Element
with Pre => Not_Empty(S), --Assertion_Error if Assertion_Policy is on
Post => (S.Length + 1 = S'Old.Length) and then
(S.Data (1..S.Length) = S'Old.Data (1 .. S'Old.Length - 1));
procedure Pop (S : in out Stack; E : out Element)
with Pre => Not_Empty(S),
Post => (S.Length = S'Old.Length - 1) and then
(S'Old.Data (S'Old.Length) = E) and then
(S.Data (1..S.Length) = S'Old.Data (1 .. S'Old.Length - 1));
end Advanced_Stacks;
---
-- advanced_stacks.adb
package body Advanced_Stacks is
procedure Push (E : Element; S: in out Stack) is
begin
S.Length := S.Length + 1;
S.Data(S.Length) := E;
end Push;
function Pop (S : in out Stack) return Element is
Result : Element := Element'First;
begin
Result := S.Data(S.Length);
--index check failed if Assertion_Policy not in effect
S.Length := S.Length - 1;
return Result;
end Pop;
procedure Pop (S : in out Stack; E : out Element) is
begin
E := S.Data (S.Length);
S.Length := S.Length - 1;
end Pop;
end Advanced_Stacks;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-13 Ed Schonberg
* exp_attr.adb (Expand_N_Attribute_Reference, case 'Old):
To determine whether the attribute should be expanded, examine
whether the enclosing postcondition pragma is to be checked,
rather than using the internal flag Assertions_Enabled.
Index: exp_attr.adb
===
--- exp_attr.adb(revision 211615)
+++ exp_attr.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -3962,13 +3962,6 @@
Temp: Entity_Id;
begin
- -- If assertions are disabled, no need to create the declaration
- -- that preserves the value.
-
- if not Assertions_Enabled then
-return;
- end if;
-
Temp := Make_Temporary (Loc, 'T', Pref);
-- Climb the parent chain looki
[Ada] GNAT.Command_Line.Get_Argument does't expand correctly with custom parser
This patches fixes the use of custom parsers when trying to expand
command line arguments like "*.adb".
When run from the test directory, the following program should output
"next source >>> test_cmd_line1.adb".
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
procedure Test_Cmd_Line1 is
Arg_Parser : Opt_Parser := Command_Line_Parser;
Switches: String_List_Access :=
new String_List'(1 => new String'("*.adb"));
begin
Initialize_Option_Scan
(Parser => Arg_Parser,
Command_Line => Switches,
Stop_At_First_Non_Switch => True,
Section_Delimiters => "cargs");
Parse_Params : loop
case GNAT.Command_Line.Getopt ("", Parser => Arg_Parser) is
when ASCII.NUL =>
loop
Put_Line ("next source >>>" &
Get_Argument (Do_Expansion => True,
Parser => Arg_Parser));
exit Parse_Params when Next_Source.all = "";
end loop;
when others =>
Put_Line (Full_Switch (Arg_Parser));
end case;
end loop Parse_Params;
end Test_Cmd_Line1;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-13 Emmanuel Briot
* g-comlin.adb (Get_Argument): fix expansion
of command line arguments (e.g. "*.adb") when using a custom
parser. The parser was not passed to the recursive call, and
thus we were trying to do the expansion on the default command
line parser.
Index: g-comlin.adb
===
--- g-comlin.adb(revision 211615)
+++ g-comlin.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2014, 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- --
@@ -402,7 +402,6 @@
end if;
if Parser.Current_Argument > Parser.Arg_Count then
-
-- If this is the first time this function is called
if Parser.Current_Index = 1 then
@@ -449,21 +448,16 @@
declare
Arg : constant String :=
Argument (Parser, Parser.Current_Argument - 1);
-Index : Positive;
-
begin
-Index := Arg'First;
-while Index <= Arg'Last loop
+for Index in Arg'Range loop
if Arg (Index) = '*'
or else Arg (Index) = '?'
or else Arg (Index) = '['
then
Parser.In_Expansion := True;
Start_Expansion (Parser.Expansion_It, Arg);
- return Get_Argument (Do_Expansion);
+ return Get_Argument (Do_Expansion, Parser);
end if;
-
- Index := Index + 1;
end loop;
end;
end if;
[Ada] Improvements to handling of pragma Compiler_Unit_Warning
We now check for null statement sequences, and for extended return
statements. In addition, the message generated now includes a
description of the non-permitted construct as shown in this
test program (compiled with -gnatj60 -gnatl)
1. pragma Ada_2012;
2. pragma Compiler_Unit_Warning;
3. function CompUnitER return Integer is
4. begin
5.begin
6. pragma List (On);
7.end;
|
>>> warning: null statement list not allowed in
compiler unit
8.return X : Integer do
|
>>> warning: extended return statement not allowed
in compiler unit
9. X := 3;
10.end return;
11. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-13 Robert Dewar
* lib.ads, lib.adb, lib-writ.adb, lib-load.adb (Is_Compiler_Unit):
Removed.
* opt.ads (Compiler_Unit): New flag.
* par-ch5.adb (Test_Statement_Required): Call Check_Compiler_Unit
for null statement sequence (not allowed in compiler unit).
* par-prag.adb (Prag): Handle Compiler_Unit[_Warning] during
parsing.
* restrict.ads, restrict.adb (Check_Compiler_Unit): New version and new
calling sequence.
* sem_ch11.adb, sem_ch3.adb, sem_ch4.adb: New calling sequence for
Check_Compiler_Unit.
* sem_ch6.adb (Analyze_Extended_Return_Statement): Call
Check_Compiler_Unit (this construct is not allowed in compiler
units).
* sem_prag.adb (Analyze_Pragma, case Compiler_Unit[_Warning]):
Set Opt.Compiler_Unit.
Index: lib.adb
===
--- lib.adb (revision 211615)
+++ lib.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -126,11 +126,6 @@
return Units.Table (U).Has_RACW;
end Has_RACW;
- function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean is
- begin
- return Units.Table (U).Is_Compiler_Unit;
- end Is_Compiler_Unit;
-
function Ident_String (U : Unit_Number_Type) return Node_Id is
begin
return Units.Table (U).Ident_String;
@@ -221,14 +216,6 @@
Units.Table (U).Has_RACW := B;
end Set_Has_RACW;
- procedure Set_Is_Compiler_Unit
- (U : Unit_Number_Type;
- B : Boolean := True)
- is
- begin
- Units.Table (U).Is_Compiler_Unit := B;
- end Set_Is_Compiler_Unit;
-
procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is
begin
Units.Table (U).Ident_String := N;
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 211615)
+++ sem_ch3.adb (working copy)
@@ -836,7 +836,7 @@
-- the runtime library but must also be compilable in Ada 95 mode
-- (when bootstrapping the compiler).
- Check_Compiler_Unit (N);
+ Check_Compiler_Unit ("anonymous access to subprogram", N);
Access_Subprogram_Declaration
(T_Name => Anon_Type,
Index: lib.ads
===
--- lib.ads (revision 211615)
+++ lib.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -326,10 +326,6 @@
-- (RACW) object. This is used for controlling generation of the RA
-- attribute in the ali file.
- --Is_Compiler_Unit
- -- A Boolean flag, initially set False by default, set to True if a
- -- pragma Compiler_Unit_Warning appears in the unit.
-
--Ident_String
-- N_String_Literal node from a valid pragma Ident that applies to
-- this unit. If no Ident pragma applies to the unit, then Empty.
@@ -415,7 +411,6 @@
function Ident_String (U : Un
[Ada] Make Task_Info pragma and package obsolescent
The functionality is now provided in a target-independent manner
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-13 Geert Bosch
* gnat_rm.texi, s-tasinf-solaris.ads, sem_prag.adb, gnat_ugn.texi,
s-tasinf-mingw.ads, s-tasinf.ads, s-tasinf-linux.ads,
s-tasinf-vxworks.ads: Make Task_Info pragma and package obsolescent.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 211615)
+++ gnat_rm.texi(working copy)
@@ -630,7 +630,6 @@
* System.Restrictions (s-restri.ads)::
* System.Rident (s-rident.ads)::
* System.Strings.Stream_Ops (s-ststop.ads)::
-* System.Task_Info (s-tasinf.ads)::
* System.Unsigned_Types (s-unstyp.ads)::
* System.Wch_Cnv (s-wchcnv.ads)::
* System.Wch_Con (s-wchcon.ads)::
@@ -1082,7 +1081,6 @@
* Pragma Suppress_Debug_Info::
* Pragma Suppress_Exception_Locations::
* Pragma Suppress_Initialization::
-* Pragma Task_Info::
* Pragma Task_Name::
* Pragma Task_Storage::
* Pragma Test_Case::
@@ -6870,27 +6868,6 @@
for other than a first subtype, then it applies only to the given subtype.
The pragma may not be given after the type is frozen.
-@node Pragma Task_Info
-@unnumberedsec Pragma Task_Info
-@findex Task_Info
-@noindent
-Syntax
-
-@smallexample @c ada
-pragma Task_Info (EXPRESSION);
-@end smallexample
-
-@noindent
-This pragma appears within a task definition (like pragma
-@code{Priority}) and applies to the task in which it appears. The
-argument must be of type @code{System.Task_Info.Task_Info_Type}.
-The @code{Task_Info} pragma provides system dependent control over
-aspects of tasking implementation, for example, the ability to map
-tasks to specific processors. For details on the facilities available
-for the version of GNAT that you are using, see the documentation
-in the spec of package System.Task_Info in the runtime
-library.
-
@node Pragma Task_Name
@unnumberedsec Pragma Task_Name
@findex Task_Name
@@ -19872,15 +19849,6 @@
stream attributes are applied to string types, but the subprograms in this
package can be used directly by application programs.
-@node System.Task_Info (s-tasinf.ads)
-@section @code{System.Task_Info} (@file{s-tasinf.ads})
-@cindex @code{System.Task_Info} (@file{s-tasinf.ads})
-@cindex Task_Info pragma
-
-@noindent
-This package provides target dependent functionality that is used
-to support the @code{Task_Info} pragma
-
@node System.Unsigned_Types (s-unstyp.ads)
@section @code{System.Unsigned_Types} (@file{s-unstyp.ads})
@cindex @code{System.Unsigned_Types} (@file{s-unstyp.ads})
@@ -22431,6 +22399,7 @@
* pragma No_Run_Time::
* pragma Ravenscar::
* pragma Restricted_Run_Time::
+* pragma Task_Info::
@end menu
@node pragma No_Run_Time
@@ -22459,6 +22428,41 @@
preferred since the Ada 2005 pragma @code{Profile} is intended for
this kind of implementation dependent addition.
+@node pragma Task_Info
+@section pragma Task_Info
+
+The functionality provided by pragma @code{Task_Info} is now part of the
+Ada language. The @code{CPU} aspect and the package
+@code{System.Multiprocessors} offer a less system-dependent way to specify
+task affinity or to query the number of processsors.
+
+@noindent
+Syntax
+
+@smallexample @c ada
+pragma Task_Info (EXPRESSION);
+@end smallexample
+
+@noindent
+This pragma appears within a task definition (like pragma
+@code{Priority}) and applies to the task in which it appears. The
+argument must be of type @code{System.Task_Info.Task_Info_Type}.
+The @code{Task_Info} pragma provides system dependent control over
+aspects of tasking implementation, for example, the ability to map
+tasks to specific processors. For details on the facilities available
+for the version of GNAT that you are using, see the documentation
+in the spec of package System.Task_Info in the runtime
+library.
+
+@node package System.Task_Info (s-tasinf.ads)
+@section package System.Task_Info (@file{s-tasinf.ads})
+
+@noindent
+This package provides target dependent functionality that is used
+to support the @code{Task_Info} pragma. The predefined Ada package
+ @code{System.Multiprocessors} and the @code{CPU} aspect now provide a
+standard replacement for GNAT's @code{Task_Info} functionality.
+
@include fdl.texi
@c GNU Free Documentation License
Index: s-tasinf-solaris.ads
===
--- s-tasinf-solaris.ads(revision 211615)
+++ s-tasinf-solaris.ads(working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
--
[Ada] Elaborate Secondary_Stack early
This patch fixes an obscure bug that causes the secondary stack to be used before it is initialized in certain cases. This can only happen if (1) the -gnatE switch is used to disable the static elaboration mode, (2) the -p switch is passed to gnatbind to tell it to choose a pessimistic (worst-case) elaboration order, and (3) gnatbind happens to choose an order in which the body of System.Tasking.Protected_Objects is elaborated before the body of System.Secondary_Stack. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Bob Duff * s-solita.adb (Get_Sec_Stack_Addr, Init_Tasking_Soft_Links): Add assertions requiring the secondary stack to be initialized. * s-solita.ads (Init_Tasking_Soft_Links): Comment. * s-taprob.adb, s-tarest.adb, s-tasini.adb (elab code): Make sure the secondary stack is initialized before calling Init_Tasking_Soft_Links, by adding pragmas Elaborate_Body. Index: s-tasini.adb === --- s-tasini.adb(revision 211609) +++ s-tasini.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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,6 +47,11 @@ with System.Tasking.Debug; with System.Parameters; +with System.Secondary_Stack; pragma Elaborate_All (System.Secondary_Stack); +pragma Unreferenced (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. + package body System.Tasking.Initialization is package STPO renames System.Task_Primitives.Operations; Index: s-tarest.adb === --- s-tarest.adb(revision 211609) +++ s-tarest.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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,9 +47,12 @@ with System.Task_Primitives.Operations; with System.Soft_Links.Tasking; -with System.Secondary_Stack; with System.Storage_Elements; +with System.Secondary_Stack; pragma Elaborate_All (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. + with System.Soft_Links; -- Used for the non-tasking routines (*_NT) that refer to global data. They -- are needed here before the tasking run time has been elaborated. used for Index: s-taprob.adb === --- s-taprob.adb(revision 211609) +++ s-taprob.adb(working copy) @@ -7,7 +7,7 @@ -- B o d y -- -- -- --Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, AdaCore -- +-- Copyright (C) 1995-2014, AdaCore -- -- -- -- 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- -- @@ -38,6 +38,10 @@ with System.Parameters; with System.Traces; with System.Soft_Links.Tasking; +with System.Secondary_Stack; pragma Elaborate_All (System.Secondary_Stack); +pragma Unreferenced (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. package body System.Tasking.Protected_Objects is Index: s-solita.adb === --- s-solita.adb(revision 211609) +++ s-solita.adb(working copy) @@ -6,7 +6,7 @@ -- -
[Ada] Non-static aggregates in Preelaborate units
This patch removes a spurious error on a unit to which the Preelaborate pragma applies. The error appeared on a unit that holds an instantiation of a package containing a type declaration with an array component whose default value is given by an actual in the instance, but the error may occur in other contexts. The improper error depended on the size of the array aggregate and whether it was given by an Others clause or an explicit range. The semantics of the pragma must of course be independent of the size of the array, as long as its expressions obey preelaborate conditions. The following must compile quietly: gcc -c preelab.adb --- with Types; with Data; procedure Preelab is X : Data.Name_Type_Array.List (2); begin if Types.Length (Types.Chars (X.Item (1))) > 0 then -- junk code X.Item (2) := X.Item (1); end if; end Preelab; --- generic type Element is private; Null_Element : in Element; package Arrays is pragma Preelaborate; type Index_Array is array (Positive range <>) of Element; type List (Size : Positive); -- must be public for embedding type Access_Key_List is access all List; type List (Size : Positive) is record -- must be public for embedding Item : Index_Array (1 .. Size) := (others => Null_Element); Used : Natural := 0; Next : Access_Key_List; end record; end Arrays; --- with Arrays; with Types; package Data is pragma Preelaborate; type Name_Type is new Types.Chars (1 .. Types.Last); package Name_Type_Array is new Arrays (Name_Type, (others => ' ')); end Data; --- package Types is pragma Preelaborate; Last : constant := 10004; subtype Chars is Wide_String; function Length (Item : in Chars) return Natural; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Ed Schonberg * sem_cat.adb (Validate_Static_Object_Name): A constant whose value is a temporary that renames an aggregate is legal in a preelaborated unit. Illegalities, if any will be detected in the aggregate components. Index: sem_cat.adb === --- sem_cat.adb (revision 211609) +++ sem_cat.adb (working copy) @@ -2048,7 +2048,8 @@ - procedure Validate_Static_Object_Name (N : Node_Id) is - E : Entity_Id; + E : Entity_Id; + Val : Node_Id; function Is_Primary (N : Node_Id) return Boolean; -- Determine whether node is syntactically a primary in an expression @@ -2151,7 +2152,8 @@ elsif Ekind (Entity (N)) = E_Constant and then not Is_Static_Expression (N) then -E := Entity (N); +E := Entity (N); +Val := Constant_Value (E); if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))) and then @@ -2169,6 +2171,21 @@ then null; +-- If the value of the constant is a local variable that renames +-- an aggregate, this is in itself legal. The aggregate may be +-- expanded into a loop, but this does not affect preelaborability +-- in itself. If some aggregate components are non-static, that is +-- to say if they involve non static primaries, they will be +-- flagged when analyzed. + +elsif Present (Val) + and then Is_Entity_Name (Val) + and then Is_Array_Type (Etype (Val)) + and then not Comes_From_Source (Val) + and then Nkind (Original_Node (Val)) = N_Aggregate +then + null; + -- This is the error case else
[Ada] Fix spurious warning on imported/exported variables with aspect
Aspects Import and Export were not treated like the equivalent pragmas wrt issuing warnings on missing initialization before use. Now fixed. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Yannick Moy * sem_ch13.adb (Analyze_Aspect_Specifications/Aspect_Import, Aspect_Export): Consider that variables may be set outside the program. Index: sem_ch13.adb === --- sem_ch13.adb(revision 211609) +++ sem_ch13.adb(working copy) @@ -1603,7 +1603,7 @@ goto Continue; end if; - -- For case of address aspect, we don't consider that we + -- For the case of aspect Address, we don't consider that we -- know the entity is never set in the source, since it is -- is likely aliasing is occurring. @@ -2691,6 +2691,19 @@ elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then + -- For the case of aspects Import and Export, we don't + -- consider that we know the entity is never set in the + -- source, since it is is likely modified outside the + -- program. + + -- Note: one might think that the analysis of the + -- resulting pragma would take care of that, but + -- that's not the case since it won't be from source. + + if Ekind (E) = E_Variable then +Set_Never_Set_In_Source (E, False); + end if; + -- Verify that there is an aspect Convention that will -- incorporate the Import/Export aspect, and eventual -- Link/External names.
[Ada] Fix spurious warning on use before def in Refined_Post aspect
The Refined_Post aspect defined in SPARK 2014 should be considered like a postcondition wrt issuing warnings on variable references. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Yannick Moy * sem_warn.adb (Check_Unset_References): Take case of Refined_Post into account in Within_Postcondition check. Index: sem_warn.adb === --- sem_warn.adb(revision 211609) +++ sem_warn.adb(working copy) @@ -1810,8 +1810,9 @@ SE : constant Entity_Id := Scope (E); function Within_Postcondition return Boolean; - -- Returns True iff N is within a Postcondition, an - -- Ensures component in a Test_Case, or a Contract_Cases. + -- Returns True iff N is within a Postcondition, a + -- Refined_Post, an Ensures component in a Test_Case, + -- or a Contract_Cases. -- -- Within_Postcondition -- @@ -1826,6 +1827,7 @@ if Nkind (Nod) = N_Pragma and then Nam_In (Pragma_Name (Nod), Name_Postcondition, + Name_Refined_Post, Name_Contract_Cases) then return True;
[Ada] Allow pragma Restrictions (No_Dependence => unit) in system.ads
This patch enables the recognition/processing of pragma Restrictions
(No_Dependence => unit) in system.ads, allowing more flexibility in
configuring specialized versions of System.
Given a system.ads that contains the line
pragma Restrictions (No_Dependence => Ada.Text_IO);
Compiling the following program gives the indicated error:
1. with Ada.Text_IO;
|
>>> violation of restriction "No_Dependence =>
Ada.Text_Io" in package System
2. procedure SysRest is
3. begin
4.Ada.Text_IO.Put_Line ("hello");
5. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-13 Robert Dewar
* back_end.adb (Make_Id): New function.
(Make_SC): New function.
(Set_RND): New procedure.
* back_end.ads (Make_Id): New function.
(Make_SC): New function.
(Set_RND): New procedure.
* einfo.ads: Minor comment updates.
* frontend.adb: Move Atree.Initialize call to Gnat1drv.
* gnat1drv.adb (Gnat1drv): New calling sequence for
Get_Target_Parameters.
(Gnat1drv): Move Atree.Initialize here from Frontend.
* targparm.adb (Get_Target_Parameters): New calling
sequence (Get_Target_Parameters): Handle pragma Restriction
(No_Dependence,..)
* targparm.ads (Get_Target_Parameters): New calling sequence.
Index: frontend.adb
===
--- frontend.adb(revision 211445)
+++ frontend.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -80,7 +80,6 @@
-- since it uses names table entries.
Rtsfind.Initialize;
- Atree.Initialize;
Nlists.Initialize;
Elists.Initialize;
Lib.Load.Initialize;
Index: einfo.ads
===
--- einfo.ads (revision 211465)
+++ einfo.ads (working copy)
@@ -101,9 +101,9 @@
-- pragma Inline declarations
-- This order must be observed. There are no restrictions on the procedures,
--- since the C header file only includes functions (Gigi is not allowed to
--- modify the generated tree). However, functions are required to have headers
--- that fit on a single line.
+-- since the C header file only includes functions (The back end is not
+-- allowed to modify the generated tree). However, functions are required to
+-- have headers that fit on a single line.
-- XEINFO reads and processes the function specs and the pragma Inlines. For
-- functions that are declared as inlined, XEINFO reads the corresponding body
@@ -121,7 +121,7 @@
-- For functions that are not inlined, there is no restriction on the body,
-- and XEINFO generates a direct reference in the C header file which allows
--- the C code in Gigi to directly call the corresponding Ada body.
+-- the C code in the backend to directly call the corresponding Ada body.
--
-- Handling of Type'Size Values --
@@ -378,16 +378,16 @@
-- the N_Attribute_Definition_Clause node. Empty if no Address clause.
-- The expression in the address clause is always a constant that is
-- defined before the entity to which the address clause applies.
--- Note: Gigi references this field in E_Task_Type entities???
+-- Note: The backend references this field in E_Task_Type entities???
--Address_Taken (Flag104)
-- Defined in all entities. Set if the Address or Unrestricted_Access
-- attribute is applied directly to the entity, i.e. the entity is the
-- entity of the prefix of the attribute reference. Also set if the
-- entity is the second argument of an Asm_Input or Asm_Output attribute,
--- as the construct may entail taking its address. Used by Gigi to make
--- sure that the address can be meaningfully taken, and also in the case
--- of subprograms to control output of certain warnings.
+-- as the construct may entail taking its address. Used by the backend to
+-- make sure that the address can be meaningfully taken, and also in the
+-- case of subprograms to control output of certain warnings.
--Aft_Value (synthesized)
-- Applies to fixed and decimal types. Computes a universal integer
@@ -415,7 +415,7 @@
-- object. A value of zero (Uint_0) indicates that the al
[Ada] Fix handling of pragma/aspect Independent[_Components]
This fixes several errors in the handling of the pragmas Independent and Independent_Components. The implementation now matches the RM definition 100%. The following compiles without errors: 1. package Independ is 2.type A1 is array (1 .. 10) of Integer; 3.pragma Independent_Components (A1); 4. 5.type A2 is array (1 .. 10) of Integer 6. with Independent_Components; 7. 8.A3 : array (1 .. 10) of Integer; 9.pragma Independent_Components (A3); 10. 11.A4 : array (1 .. 10) of Integer 12. with Independent_Components; 13. 14.type R1 is record 15. X, Y : Integer; 16.end record; 17.pragma Independent_Components (R1); 18. 19.type R2 is record 20. X, Y : Integer; 21.end record 22. with Independent_Components; 23. 24.type R3 is record 25. X, Y : Integer; 26. pragma Independent (X); 27.end record; 28. 29.type R4 is record 30. X : Integer with Independent; 31. Y : Integer; 32.end record; 33. end; The following test compiles with the errors shown 1. package Independ2 is 2.type A1 is array (1 .. 10) of Boolean; 3.for A1'Component_Size use 1; 4.pragma Independent_Components (A1); | >>> independent components cannot be guaranteed for "A1" 5. 6.type A2 is array (1 .. 10) of Boolean 7. with Independent_Components, | >>> independent components cannot be guaranteed for "A2" 8. Component_Size => 1; 9. 10.type R1 is record 11. X, Y : Boolean; 12.end record; 13.pragma Independent_Components (R1); | >>> independent components cannot be guaranteed for "R1" >>> because of Component_Clause at line 15 14.for R1 use record 15. X at 0 range 0 .. 0; 16. Y at 0 range 1 .. 1; 17.end record; 18. 19.type R2 is record 20. X, Y : Boolean; 21.end record 22. with Independent_Components; | >>> independent components cannot be guaranteed for "R2" >>> because of Component_Clause at line 24 23.for R2 use record 24. X at 0 range 0 .. 0; 25. Y at 0 range 1 .. 1; 26.end record; 27. 28.type R3 is record 29. X, Y : Boolean; 30. pragma Independent (X); | >>> independence cannot be guaranteed for "X" >>> because of Component_Clause at line 33 31.end record; 32.for R3 use record 33. X at 0 range 0 .. 0; 34. Y at 0 range 1 .. 1; 35.end record; 36. 37.type R4 is record 38. X : Boolean with Independent; | >>> independence cannot be guaranteed for "X" >>> because of Component_Clause at line 42 39. Y : Boolean; 40.end record; 41.for R4 use record 42. X at 0 range 0 .. 0; 43. Y at 0 range 1 .. 1; 44.end record; 45. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-11 Robert Dewar * einfo.adb (Is_Independent): New flag. * einfo.ads (Is_Independent): New flag. (Has_Independent_Components): Clean up and fix comments. * sem_prag.adb (Fix_Error): Deal with changing argument [of] to entity [for]. (Analyze_Pragma, case Independent): Set Is_Independent flag (Analyze_Pragma, case Independent_Components): Set Is_Independent flag in all components of specified record. Index: einfo.adb === --- einfo.adb (revision 211445) +++ einfo.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -558,12 +558,12 @@ --SPARK_Pragma_Inherited Flag265 --SPARK_Aux_Pragma_Inherited Flag266 --Has_Shift_Operator Flag267 + --Is_Independent Flag268 --(unused)Flag1 --(unused)Flag2 --(unused)Flag3 - --(unused)Flag268 --(unused)
[Ada] Consistent processing of preelaborated units across language versions
The processing of pragma Preelaborate_05 might cause inconsistent compiler behaviour when a given unit having the pragma appears in the dependencies of both an Ada 95 and and Ada 2005 unit in the same closure. This is addressed by making runtime units Preelaborate in all cases. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-11 Thomas Quinot * a-astaco.ads, a-tags.ads, s-excdeb.ads, a-tgdico.ads, a-stmaco.ads, a-except-2005.ads, s-except.ads, a-taside.ads, a-dynpri.ads, a-chahan.ads, a-sytaco.ads, s-stalib.ads, a-strmap.ads: Change pragmas Preelaborate_05 to just Preelaborate in runtime units, and similarly change Pure_05 to just Pure. Index: a-astaco.ads === --- a-astaco.ads(revision 211445) +++ a-astaco.ads(working copy) @@ -27,7 +27,7 @@ with Ada.Task_Identification; package Ada.Asynchronous_Task_Control is - pragma Preelaborate_05; + pragma Preelaborate; -- In accordance with Ada 2005 AI-362 pragma Unimplemented_Unit; Index: a-tags.ads === --- a-tags.ads (revision 211445) +++ a-tags.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -37,7 +37,7 @@ with System.Storage_Elements; package Ada.Tags is - pragma Preelaborate_05; + pragma Preelaborate; -- In accordance with Ada 2005 AI-362 type Tag is private; Index: s-excdeb.ads === --- s-excdeb.ads(revision 211445) +++ s-excdeb.ads(working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2014, 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- -- @@ -39,7 +39,7 @@ package System.Exceptions_Debug is - pragma Preelaborate_05; + pragma Preelaborate; -- To let Ada.Exceptions "with" us and let us "with" Standard_Library package SSL renames System.Standard_Library; Index: a-tgdico.ads === --- a-tgdico.ads(revision 211445) +++ a-tgdico.ads(working copy) @@ -25,7 +25,7 @@ function Ada.Tags.Generic_Dispatching_Constructor (The_Tag : Tag; Params : not null access Parameters) return T'Class; -pragma Preelaborate_05 (Generic_Dispatching_Constructor); +pragma Preelaborate (Generic_Dispatching_Constructor); pragma Import (Intrinsic, Generic_Dispatching_Constructor); -- Note: the reason that we use Preelaborate_05 here is so that this will -- compile fine during the normal build procedures. In Ada 2005 mode (which Index: a-stmaco.ads === --- a-stmaco.ads(revision 211445) +++ a-stmaco.ads(working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -36,8 +36,7 @@ with Ada.Characters.Latin_1; package Ada.Strings.Maps.Constants is - pragma Preelaborate; - pragma Pure_05; + pragma Pure; -- In accordance with Ada 2005 AI-362 Control_Set : constant Character_Set; Index: a-except-2005.ads === --- a-except-2005.ads (revisio
[Ada] Better handling of variant records with No_Implicit_Conditionals
Previously, an attempt to declare a variant record type was rejected if restriction No_Implicit_Conditionals was active, since the resulting generated equality and initialization routines contained implicit tests. Now such declarations are allowed, but these routines are not generated if the restriction is active. Furthermore, if the restriction is active, then any attempt to do a comparison of variant records, or to default initialize such a record, will be considered a violation. The following test is compiled with -gnatl -gnatj65 in the presence of a gnat.adc file containing pragma Restrictions (No_Implicit_Conditionals). 1. package NICDisc is 2. type Enum is (One, Two, Three, Four); 3. type Variant (En : Enum) is record 4.E : Enum := En; 5.case En is 6. when One => 7. I : Integer := 0; 8. when Two => 9. B : Boolean := True; 10. I2 : Integer; 11. when Three | Four => 12. null; 13.end case; 14. end record; 15. end NICDisc; 1. with NICDisc; use NICDisc; 2. package NICDiscr is 3.W : Variant (Two); | >>> violation of restriction "No_Implicit_Conditionals" at gnat.adc:1, initialization of variant record tests discriminants 4.X : Variant := (One, Two, 23); 5.Y : Variant := (Two, Two, True, 24); 6.M : Boolean := X = Y; | >>> violation of restriction "No_Implicit_Conditionals" at gnat.adc:1, comparison of variant records tests discriminants 7. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-11 Robert Dewar * exp_ch3.adb (Build_Record_Init_Proc): Don't build for variant record type if restriction No_Implicit_Conditionals is active. (Expand_N_Object_Declaration): Don't allow default initialization for variant record type if restriction No_Implicit_Condition is active. (Build_Variant_Record_Equality): Don't build for variant record type if restriction No_Implicit_Conditionals is active. * exp_ch4.adb (Expand_N_Op_Eq): Error if variant records with No_Implicit_Conditionals. * sem_aux.ads, sem_aux.adb (Has_Variant_Part): New function. Index: sem_aux.adb === --- sem_aux.adb (revision 211445) +++ sem_aux.adb (working copy) @@ -666,6 +666,51 @@ end if; end Has_Unconstrained_Elements; + -- + -- Has_Variant_Part -- + -- + + function Has_Variant_Part (Typ : Entity_Id) return Boolean is + FSTyp : Entity_Id; + Decl : Node_Id; + TDef : Node_Id; + CList : Node_Id; + + begin + if not Is_Type (Typ) then + return False; + end if; + + FSTyp := First_Subtype (Typ); + + if not Has_Discriminants (FSTyp) then + return False; + end if; + + -- Proceed with cautious checks here, return False if tree is not + -- as expected (may be caused by prior errors). + + Decl := Declaration_Node (FSTyp); + + if Nkind (Decl) /= N_Full_Type_Declaration then + return False; + end if; + + TDef := Type_Definition (Decl); + + if Nkind (TDef) /= N_Record_Definition then + return False; + end if; + + CList := Component_List (TDef); + + if Nkind (CList) /= N_Component_List then + return False; + else + return Present (Variant_Part (CList)); + end if; + end Has_Variant_Part; + - -- In_Generic_Body -- - Index: sem_aux.ads === --- sem_aux.ads (revision 211445) +++ sem_aux.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -255,6 +255,10 @@ -- True if T has discriminants and is unconstrained, or is an array type -- whose element type Has_Unconstrained_Elements. + function Has_Variant_Part (Typ : Entity_Id) return Boolean; + -- Return True if the first subtype of Typ is a discriminated record type + -- which has a variant part. False otherwise. + function In_Generic_Body (Id : Entity_Id) return
[Ada] Error not detected in illegal selected component
This patch corrects an error in the resolution of selected components when the prefix is overloaded and none of the interpretations matches the context. Compiling resolve_func_deref_comp.adb must yield: resolve_func_deref_comp.adb:14:18: no interpretation matches type access to "T" defined at line 12 resolve_func_deref_comp.adb:14:18: expected type must be a general access type -- procedure Resolve_Func_Deref_Comp is type T is null record; type Acc_T is access T; type Rec is record T_Comp : Acc_T; end record; type Acc_Rec is access all Rec; function F return Integer is (0); function F return Acc_Rec is (null); begin declare Some_T : access T; begin Some_T := F.T_Comp; end; end Resolve_Func_Deref_Comp; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-11 Ed Schonberg * sem_res.adb (Resolve_Selected_Component): Handle properly a selected component whose prefix is overloaded, when none of the interpretations matches the expected type. Index: sem_res.adb === --- sem_res.adb (revision 211445) +++ sem_res.adb (working copy) @@ -9159,7 +9159,7 @@ Comp := First_Entity (T); while Present (Comp) loop if Chars (Comp) = Chars (S) -and then Covers (Etype (Comp), Typ) +and then Covers (Typ, Etype (Comp)) then if not Found then Found := True; @@ -9213,6 +9213,9 @@ Get_Next_Interp (I, It); end loop Search; + -- There must be a legal interpreations at this point. + + pragma Assert (Found); Resolve (P, It1.Typ); Set_Etype (N, Typ); Set_Entity_With_Checks (S, Comp1); @@ -9240,6 +9243,7 @@ if Is_Access_Type (Etype (P)) then T := Designated_Type (Etype (P)); Check_Fully_Declared_Prefix (T, P); + else T := Etype (P); end if;
[Ada] gnat link and shared libraries
When "gnat link" is invoked and there are shared libraries, the link may
be incorrect on some platforms, such as Windows. This is fixed by this patch.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-11 Vincent Celier
* gnatcmd.adb (Process_Link): Do not invoke gnatlink with
-lgnarl or -lgnat.
Index: gnatcmd.adb
===
--- gnatcmd.adb (revision 211445)
+++ gnatcmd.adb (working copy)
@@ -1075,18 +1075,8 @@
if Libraries_Present then
- -- Add -L -lgnarl -lgnat -Wl,-rpath,
+ -- Add -Wl,-rpath,
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-L" & MLib.Utl.Lib_Directory);
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-lgnarl");
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-lgnat");
-
-- If Path_Option is not null, create the switch ("-Wl,-rpath," or
-- equivalent) with all the library dirs plus the standard GNAT
-- library dir.
[Ada] Analyze contracts of subprogram body stubs
This patch ensures that contract of subprogram body stubs are analyzed in timely fashion. -- Source -- -- pack.ads package Pack with SPARK_Mode, Abstract_State => State, Initializes=> (Var_1, State) is Var_1 : Integer := 0; procedure Double with Global => (In_Out => (State, Var_1)); procedure Error_1 with Global => (In_Out => State); end Pack; -- pack-double.adb separate (Pack) procedure Double with SPARK_Mode is begin Var_1 := Var_1 * 2; end Double; -- pack-double_a.adb separate (Pack) procedure Double_A with SPARK_Mode is begin Var_2 := Var_2 * 2; end Double_A; -- pack-error_1.adb separate (Pack) procedure Error_1 with SPARK_Mode is begin null; end Error_1; -- pack-error_2.adb separate (Pack) procedure Error_2 with SPARK_Mode is begin null; end Error_2; -- pack.adb package body Pack with SPARK_Mode, Refined_State => (State => Var_2) is Var_2 : Integer := 0; procedure Double is separate with Refined_Global => (In_Out => (Var_1, Var_2)); procedure Double_A is separate with Global => (In_Out => Var_2); procedure Error_1 is separate with Refined_Global => (In_Out => Junk_1); procedure Error_2 is separate with Global => (In_Out => Junk_2); end Pack; -- Compilation and output -- $ gcc -c pack.adb pack.adb:14:40: "Junk_1" is undefined pack.adb:17:32: "Junk_2" is undefined Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-11 Hristian Kirtchev * sem_ch3.adb Add with and use clause for Sem_Ch10. (Analyze_Declarations): Code reformatting. Analyze the contract of a subprogram body stub at the end of the declarative region. * sem_ch6.adb (Analyze_Subprogram_Body_Contract): Spec_Id is now a variable. Do not process the body if its contract is not available. Account for subprogram body stubs when extracting the corresponding spec. * sem_ch6.ads (Analyze_Subprogram_Contract): Update the comment on usage. * sem_ch10.ads, sem_ch10.adb (Analyze_Subprogram_Body_Stub_Contract): New routine. * sem_prag.adb (Analyze_Depends_In_Decl_Part): Account for subprogram body stubs when extracting the corresponding spec. (Analyze_Global_In_Decl_List): Account for subprogram body stubs when extracting the corresponding spec. (Analyze_Refined_Depends_In_Decl_Part): Use Find_Related_Subprogram_Or_Body to retrieve the declaration of the related body. Spec_Is now a variable. Account for subprogram body stubs when extracting the corresponding spec. (Analyze_Refined_Global_In_Decl_Part): Use Find_Related_Subprogram_Or_Body to retrieve the declaration of the related body. Spec_Is now a variable. Account for subprogram body stubs when extracting the corresponding spec. (Collect_Subprogram_Inputs_Output): Account for subprogram body stubs when extracting the corresponding spec. Index: sem_ch3.adb === --- sem_ch3.adb (revision 211448) +++ sem_ch3.adb (working copy) @@ -57,6 +57,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; @@ -2371,13 +2372,16 @@ if Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); + elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration, + N_Subprogram_Declaration) + then +Analyze_Subprogram_Contract (Defining_Entity (Decl)); + elsif Nkind (Decl) = N_Subprogram_Body then Analyze_Subprogram_Body_Contract (Defining_Entity (Decl)); - elsif Nkind_In (Decl, N_Subprogram_Declaration, - N_Abstract_Subprogram_Declaration) - then -Analyze_Subprogram_Contract (Defining_Entity (Decl)); + elsif Nkind (Decl) = N_Subprogram_Body_Stub then +Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl)); end if; Next (Decl); Index: sem_ch10.adb === --- sem_ch10.adb(revision 211445) +++ sem_ch10.adb(working copy) @@ -1879,6 +1879,39 @@ end if; end Analyze_Protected_Body_Stub; + --- + -- Analyze_Subprogram_Body_Stub_Contract -- + --- + + procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id) is + Stub_Decl : constant Node_Id := Parent (Parent (Stub_Id)); + Spec_Id : constant Entity_Id := Corresponding_Spec_Of_Stub (Stub_Decl); + + begin
[Ada] Cleanup handling of info and warning messages
This is a fairly major internal reorganization of how info and warning
messages are handled. Info messages for elaboration are now tagged
as [-gnatel] if warning tagging is activated (-gnatw.d), and info
messages coming from instantiations are consistently labeled as such
as shown by this example, compiled with -gnatw.e -gnatl
1. generic
2. package IWInfoD is
3. type Handle_Type is private;
4. function CH return Handle_Type;
|
>>> info: "IWInfoD" requires body ("CH" requires completion)
5. private
6. type Handle_Type is
7. record
8. Initialised : Boolean;
9. end record;
10. end;
1. package body IWInfoD is
2. function CH return Handle_Type is
3. begin
4. return (Initialised => False);
5. end CH;
6. end;
1. with IWInfoD;
2. generic
3. with package My_D is new IWInfoD;
|
>>> info: in instantiation at iwinfod.ads:4
>>> info: "My_D" requires body ("CH" requires completion)
4. with procedure Method (Client : in out My_D.Handle_Type);
5. package IWInfo is
6. private
7. procedure C;
|
>>> info: "IWInfo" requires body ("C" requires completion)
8. end;
1. package body IWInfoD is
2. function CH return Handle_Type is
3. begin
4. return (Initialised => False);
5. end CH;
6. end;
prior to this fix the messages on line 3 of the IWinfo spec
were inconsistent with the first saying warning: and the
second saying info: which was confusing
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-11 Robert Dewar
* errout.adb (Warn_Insertion): New function.
(Error_Msg): Use Warn_Insertion and Prescan_Message.
(Error_Msg_Internal): Set Info field of error object.
(Error_Msg_NEL): Use Prescan_Message.
(Set_Msg_Text): Don't store info: at start of message.
(Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning.
(Skip_Msg_Insertion_Warning): Now just skips warning insertion.
* errout.ads: Document new ?$? and >$> insertion sequences
Document use of "(style)" and "info: "
* erroutc.adb (dmsg): Print several missing fields
(Get_Warning_Tag): Handle -gnatel case (?$?) (Output_Msg_Text):
Deal with new tagging of info messages
* erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object):
Add field Info (Prescan_Message): New procedure, this procedure
replaces the old Test_Style_Warning_Serious_Unconditional_Msg
* errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb,
sem_elab.adb: Follow new rules for info message (info belongs
only at the start of a message, and only in the first message,
not in any of the continuations).
* gnat_ugn.texi: Document full set of warning tags.
Index: errout.adb
===
--- errout.adb (revision 211445)
+++ errout.adb (working copy)
@@ -197,6 +197,17 @@
-- spec for precise definition of the conversion that is performed by this
-- routine in OpenVMS mode.
+ function Warn_Insertion return String;
+ -- This is called for warning messages only (so Warning_Msg_Char is set)
+ -- and returns a corresponding string to use at the beginning of generated
+ -- auxiliary messages, such as "in instantiation at ...".
+ --'a' .. 'z' returns "?x?"
+ --'A' .. 'Z' returns "?X?"
+ --'*' returns "?*?"
+ --'$' returns "?$?info: "
+ --' ' returns " "
+ -- No other settings are valid
+
---
-- Change_Error_Text --
---
@@ -282,7 +293,7 @@
-- Start of processing for new message
Sindex := Get_Source_File_Index (Flag_Location);
- Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+ Prescan_Message (Msg);
Orig_Loc := Original_Location (Flag_Location);
-- If the current location is in an instantiation, the issue arises of
@@ -332,8 +343,7 @@
-- that style checks are not considered warning messages for this
-- purpose.
- if Is_Warning_Msg
-and then Warnings_Suppressed (Orig_Loc) /= No_String
+ if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
then
return;
@@ -438,9 +448,9 @@
-- Case of inlined body
if Inlined_Body (X) then
- if Is_Warning_Msg or else Is_Style_Msg then
+ if Is_Warning_Msg or Is_Style_Msg then
Error_Msg_Internal
- ("?in inlined body #",
+ (Warn_Insertion & "in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
else
Error_Msg_Internal
Re: [PATCH] Add support for GNU/Hurd in gnat-4.9
BTW, > I wonder ho the kfreebsd people managed to get accepted upstream? This is typically a good example of patches being accepted too rapidly, and leading to maintenance issues, see: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=56274 for which nobody is stepping up to fix. So we might well end up removing support for Ada/kfreebsd soon. Arno
[Ada] Implement new restriction No_Fixed_IO
A new restriction No_Fixed_IO, which requires partition-wide consistent use, forbids fixed I/O operations which may end up using floating-point at run-time. These include any refernce to Fixed_IO or Decimal_IO in packages Ada.Text_IO, Ada.Wide_Text_IO, and Ada.Wide_Wide_Text_IO, and any use of the attributes Img, Image, Value, Wide_Image, Wide_Value, Wide_Wide_Image, Wide_Wide_Value with ordinary or decimal fixed-point. The following is compiled with -gnatws -gnatl: 1. pragma Restrictions (No_Fixed_IO); 2. with Text_IO; 3. with Ada.Wide_Text_IO; 4. with Ada.Wide_Wide_Text_IO; 5. use Ada.Wide_Wide_Text_IO; 6. package NoFixedIO is 7.pragma Inspection_Point; 8.type F is delta 0.25 range 0.0 .. 10.0; 9.type D is delta 0.1 digits 3 range 0.0 .. 99.9; 10.package MyFIO is new Text_IO.Fixed_IO (F); | >>> violation of restriction "No_Fixed_Io" at line 1 11.package MyDIO is new Text_IO.Decimal_IO (D); | >>> violation of restriction "No_Fixed_Io" at line 1 12.package MyFIOW is new Ada.Wide_Text_IO.Fixed_IO (F); | >>> violation of restriction "No_Fixed_Io" at line 1 13.package MyDIOW is new Ada.Wide_Text_IO.Decimal_IO (D); | >>> violation of restriction "No_Fixed_Io" at line 1 14.package MyFIOWW is new Ada.Wide_Wide_Text_IO.Fixed_IO (F); | >>> violation of restriction "No_Fixed_Io" at line 1 15.package MyDIOWW is new Ada.Wide_Wide_Text_IO.Decimal_IO (D); | >>> violation of restriction "No_Fixed_Io" at line 1 16.FV : F; 17.DV : D; 18.S1 : String := FV'Img; | >>> violation of restriction "No_Fixed_Io" at line 1 19.S2 : String := F'Image (FV); | >>> violation of restriction "No_Fixed_Io" at line 1 20.S3 : String := D'Image (DV); | >>> violation of restriction "No_Fixed_Io" at line 1 21.S4 : Wide_String := F'Wide_Image (FV); | >>> violation of restriction "No_Fixed_Io" at line 1 22.S5 : Wide_String := D'Wide_Image (DV); | >>> violation of restriction "No_Fixed_Io" at line 1 23.S6 : Wide_Wide_String := F'Wide_Wide_Image (FV); | >>> violation of restriction "No_Fixed_Io" at line 1 24.S7 : Wide_Wide_String := D'Wide_Wide_Image (DV); | >>> violation of restriction "No_Fixed_Io" at line 1 25.F1 : F := F'Value (S2); | >>> violation of restriction "No_Fixed_Io" at line 1 26.D1 : D := D'Value (S3); | >>> violation of restriction "No_Fixed_Io" at line 1 27.F2 : F := F'Wide_Value (S4); | >>> violation of restriction "No_Fixed_Io" at line 1 28.D2 : D := D'Wide_Value (S5); | >>> violation of restriction "No_Fixed_Io" at line 1 29.F3 : F := F'Wide_Wide_Value (S6); | >>> violation of restriction "No_Fixed_Io" at line 1 30.D3 : D := D'Wide_Wide_Value (S7); | >>> violation of restriction "No_Fixed_Io" at line 1 31. end NoFixedIO; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar * restrict.ads (Implementation_Restriction): Add entry for No_Fixed_IO. * rtsfind.ads: Add entries for Fixed_IO and Decimal_IO in Ada.[Wide_[Wide_]Text_IO. * s-rident.ads (Restriction_Id): Add entry for No_Fixed_IO. * sem_attr.adb (Analyze_Attribute): Disallow fixed point types for Img, Image, Value, Wide_Image, Wide_Value, Wide_Wide_Image, Wide_Wide_Value if restriction No_Fixed_IO is set. * sem_util.adb (Set_Entity_Checks): Check restriction No_Fixed_IO. Index: rtsfind.ads === --- rtsfind.ads (revision 210697) +++ rtsfind.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or
[Ada] Reject the use of volatiles in assertion expressions
This patch corrects the trigger which determines the proper context of a
volatile object with enabled property Async_Writers or Effective_Reads.
-- Source --
-- assert_exprs.ads
package Assert_Exprs with SPARK_Mode is
type T is new Integer with Volatile;
procedure Error (Input : T; Output : out T)
with Pre => Input > 1,
Post => Output = Input * 2;
end Assert_Exprs;
-- assert_exprs.adb
package body Assert_Exprs with SPARK_Mode is
procedure Error (Input : T; Output : out T) is
begin
Output := Input * 2;
end Error;
end Assert_Exprs;
-- Compilation and output --
$ gcc -c -gnata assert_exprs.adb
assert_exprs.adb:4:17: volatile object cannot appear in this context (SPARK RM
7.1.3(13))
assert_exprs.ads:5:19: volatile object cannot appear in this context (SPARK RM
7.1.3(13))
assert_exprs.ads:6:19: volatile object cannot appear in this context (SPARK RM
7.1.3(13))
assert_exprs.ads:6:28: volatile object cannot appear in this context (SPARK RM
7.1.3(13))
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Hristian Kirtchev
* freeze.adb (Freeze_Record_Type): Update the use of
Is_SPARK_Volatile.
* sem_ch3.adb (Analyze_Object_Contract): Update the use of
Is_SPARK_Volatile.
(Process_Discriminants): Update the use of Is_SPARK_Volatile.
* sem_ch5.adb (Analyze_Iterator_Specification): Update the use
of Is_SPARK_Volatile.
(Analyze_Loop_Parameter_Specification):
Update the use of Is_SPARK_Volatile.
* sem_ch6.adb (Process_Formals): Catch an illegal use of an IN
formal parameter when its type is volatile.
* sem_prag.adb (Analyze_Global_Item): Update the use of
Is_SPARK_Volatile.
* sem_res.adb (Resolve_Entity_Name): Correct the guard which
determines whether an entity is a volatile source SPARK object.
* sem_util.adb (Has_Enabled_Property): Accout for external
properties being set on objects other than abstract states
and variables. An example would be a formal parameter.
(Is_SPARK_Volatile): New routine.
(Is_SPARK_Volatile_Object):
Remove the entity-specific tests. Call routine Is_SPARK_Volatile
when checking entities and/or types.
* sem_util.ads (Is_SPARK_Volatile): New routine.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 210705)
+++ sem_ch3.adb (working copy)
@@ -2988,7 +2988,7 @@
-- actuals in instantiations (SPARK RM 7.1.3(6)).
if SPARK_Mode = On
- and then Is_SPARK_Volatile_Object (Obj_Id)
+ and then Is_SPARK_Volatile (Obj_Id)
and then No (Corresponding_Generic_Association (Parent (Obj_Id)))
then
Error_Msg_N ("constant cannot be volatile", Obj_Id);
@@ -3000,7 +3000,7 @@
-- they are not standard Ada legality rules.
if SPARK_Mode = On then
-if Is_SPARK_Volatile_Object (Obj_Id) then
+if Is_SPARK_Volatile (Obj_Id) then
-- The declaration of a volatile object must appear at the
-- library level (SPARK RM 7.1.3(7), C.6(6)).
@@ -3030,7 +3030,7 @@
-- A non-volatile object cannot have volatile components
-- (SPARK RM 7.1.3(7)).
- if not Is_SPARK_Volatile_Object (Obj_Id)
+ if not Is_SPARK_Volatile (Obj_Id)
and then Has_Volatile_Component (Obj_Typ)
then
Error_Msg_N
@@ -18051,7 +18051,7 @@
-- (SPARK RM 7.1.3(6)).
if SPARK_Mode = On
- and then Is_SPARK_Volatile_Object (Defining_Identifier (Discr))
+ and then Is_SPARK_Volatile (Defining_Identifier (Discr))
then
Error_Msg_N ("discriminant cannot be volatile", Discr);
end if;
Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 210707)
+++ sem_ch5.adb (working copy)
@@ -1986,7 +1986,7 @@
if SPARK_Mode = On
and then not Of_Present (N)
-and then Is_SPARK_Volatile_Object (Ent)
+and then Is_SPARK_Volatile (Ent)
then
Error_Msg_N ("loop parameter cannot be volatile", Ent);
end if;
@@ -2706,7 +2706,7 @@
-- when SPARK_Mode is on as it is not a standard Ada legality check
-- (SPARK RM 7.1.3(6)).
- if SPARK_Mode = On and then Is_SPARK_Volatile_Object (Id) then
+ if SPARK_Mode = On and then Is_SPARK_Volatile (Id) then
Error_Msg_N ("loop parameter cannot be volatile", Id);
end if;
end Analyze_Loop_Parameter_Specification;
Index: sem_prag.adb
===
--- sem_prag.adb(revision 210702)
+++ sem_prag.adb(working copy)
@
[Ada] Warnings on use of uninitialized entities in an instance
This patch adds warnings to uses of potentially uninitialzed entities in instances. If an entity of a generic type has default initialization, then the corresponding actual type should be fully initialized, or else there will be uninitialized components in the instantiation that might go unreported, because in general we do not emit warnings within instances. The new predicate May_Need_Initialized_Actual allows the compiler to emit an appropriate warning in the generic itself, and a corresponding one in the instance if the actual is not fully initialized. In a sense, the use of a type that requires full initialization is a weak part of the generic contract, and this patch makes this weak obligation explicit. Compiling warn.adb must yield: warn.adb:12:06: warning: variable "Problem" of a generic type is potentially uninitialized warn.adb:12:06: warning: instantiations must provide fully initialized type for "GR" warn.adb:16:04: warning: in instantiation at line 7 warn.adb:16:04: warning: from its use in generic unit, actual for "GR" should be fully initialized type --- procedure Warn is type R is record V : Integer; end record; generic type GR is private; package G is Thing : GR; end G; package body G is Problem : GR; end; type R2 is new R; package I is new G (R2); begin null; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Ed Schonberg * sinfo.ads, sinfo.adb: New flag Needs_Initialized_Actual, present in formal_Private_Definitions and on private extension declarations of a formal derived type. Set when the use of the formal type in a generic suggests that the actual should be a fully initialized type. * sem_warn.adb (May_Need_Initialized_Actual): new subprogram to indicate that an entity of a generic type has default initialization, and that the corresponing actual type in any subsequent instantiation should be fully initialized. * sem_ch12.adb (Check_Initialized_Type): new subprogram, to emit a warning if the actual for a generic type on which Needs_Initialized_Actual is set is not a fully initialized type. Index: sinfo.adb === --- sinfo.adb (revision 210697) +++ sinfo.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -2224,6 +2224,15 @@ return List2 (N); end Names; + function Needs_Initialized_Actual + (N : Node_Id) return Boolean is + begin + pragma Assert (False +or else NT (N).Nkind = N_Formal_Private_Type_Definition +or else NT (N).Nkind = N_Private_Extension_Declaration); + return Flag18 (N); + end Needs_Initialized_Actual; + function Next_Entity (N : Node_Id) return Node_Id is begin @@ -5364,6 +5373,15 @@ Set_List2_With_Parent (N, Val); end Set_Names; + procedure Set_Needs_Initialized_Actual + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False +or else NT (N).Nkind = N_Formal_Private_Type_Definition +or else NT (N).Nkind = N_Private_Extension_Declaration); + Set_Flag18 (N, Val); + end Set_Needs_Initialized_Actual; + procedure Set_Next_Entity (N : Node_Id; Val : Node_Id) is begin Index: sinfo.ads === --- sinfo.ads (revision 210697) +++ sinfo.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1701,6 +1701,12 @@ --present in an N_Subtype_Indication node, since we also use these in --calls to Freeze_Expression. + -- Needs_Initialized_Actual (Flag18-Sem) + --Present in
[Ada] Proper handling of packed array of small record with reverse SSO
This change ensures proper processing for a packed array of 4-bit records
specified with reverse scalar storage order.
The following program must compile quietly and execute as shown:
$ gnatmake -q reduced_pkd_array_small_rec
$ ./reduced_pkd_array_small_rec
Config 0 = 1
Config 1 = 3
Config 2 = 5
Config 3 = 7
Bit pattern: 19 87
with Ada.Text_Io; use Ada.Text_IO;
with System.Storage_Elements; use System.Storage_Elements;
procedure reduced_pkd_array_small_rec is
type Int3 is range 0 .. 7;
for Int3'Size use 3;
type Small_Rec is record
B : Boolean := False;
I : Int3:= 0;
end record;
pragma pack (Small_Rec);
for Small_Rec'Size use 4;
for Small_Rec'Bit_Order use System.High_Order_First;
for Small_Rec'Scalar_Storage_Order use System.High_Order_First;
for Small_Rec use record
B at 0 range 0 .. 0;
I at 0 range 1 .. 3;
end record;
type Pakd_Array is array (Integer range 0 .. 3) of Small_Rec;
pragma pack (Pakd_Array);
for Pakd_Array'Scalar_Storage_Order use System.High_Order_First;
Config : Pakd_Array;
SA : Storage_Array (1 .. Config'Size / 8);
for SA'Address use Config'Address;
pragma Import (Ada, SA);
begin
Config(0).I := 1;
Config(1).I := 3;
Config(2).I := 5;
Config(3).I := 7;
Put_Line ("Config 0 = " & Config(0).I'Img);
Put_Line ("Config 1 = " & Config(1).I'Img);
Put_Line ("Config 2 = " & Config(2).I'Img);
Put_Line ("Config 3 = " & Config(3).I'Img);
Put ("Bit pattern:");
for J in SA'Range loop
Put (" " & SA (J)'Img);
end loop;
New_Line;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Thomas Quinot
* exp_pakd.adb (Byte_Swap): Handle the case of a sub-byte
component. No byte swapping occurs, but this procedure also takes
care of appropriately justifying the argument.
Index: exp_pakd.adb
===
--- exp_pakd.adb(revision 210703)
+++ exp_pakd.adb(working copy)
@@ -576,20 +576,26 @@
Shift : Uint;
begin
- pragma Assert (T_Size > 8);
+ if T_Size <= 8 then
+ Swap_F := Empty;
+ Swap_T := RTE (RE_Unsigned_8);
- if T_Size <= 16 then
- Swap_RE := RE_Bswap_16;
+ else
+ if T_Size <= 16 then
+Swap_RE := RE_Bswap_16;
- elsif T_Size <= 32 then
- Swap_RE := RE_Bswap_32;
+ elsif T_Size <= 32 then
+Swap_RE := RE_Bswap_32;
- else pragma Assert (T_Size <= 64);
- Swap_RE := RE_Bswap_64;
+ else pragma Assert (T_Size <= 64);
+Swap_RE := RE_Bswap_64;
+ end if;
+
+ Swap_F := RTE (Swap_RE);
+ Swap_T := Etype (Swap_F);
+
end if;
- Swap_F := RTE (Swap_RE);
- Swap_T := Etype (Swap_F);
Shift := Esize (Swap_T) - T_Size;
Arg := RJ_Unchecked_Convert_To (Swap_T, N);
@@ -601,10 +607,14 @@
Right_Opnd => Make_Integer_Literal (Loc, Shift));
end if;
- Swapped :=
-Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Swap_F, Loc),
- Parameter_Associations => New_List (Arg));
+ if Present (Swap_F) then
+ Swapped :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Swap_F, Loc),
+ Parameter_Associations => New_List (Arg));
+ else
+ Swapped := Arg;
+ end if;
if Right_Justify and then Shift > Uint_0 then
Swapped :=
[Ada] Overriding_Indicators not legal on protected subprogram bodies
The compiler incorrectly allows overriding_indicators to be applied
to protected subprogram bodies (and flags a style error with -gnatyO
when they're missing), but those are disallowed by the Ada RM (see
RM-8.3.1(3-6) and AC95-00213 for confirmation of intent). This is
fixed, but the error can be changed to a warning with -gnatd.E to
ease transition for programs that were using such overriding_indicators.
The test below must report the following style warning and error
when compiled with:
$ gcc -c -gnatyO -gnatj60 prot_subp_indicator_bug.adb
prot_subp_indicator_bug.adb:17:07: (style) missing
"overriding" indicator
in declaration of "P"
prot_subp_indicator_bug.adb:32:07: overriding indicator not
allowed for protected
subprogram body
and the following warnings when compiled with:
$ gcc -c -gnatyO -gnatd.E -gnatj60 prot_subp_indicator_bug.adb
prot_subp_indicator_bug.adb:17:07: (style) missing
"overriding" indicator
in declaration of "P"
prot_subp_indicator_bug.adb:32:07: warning: overriding
indicator not allowed
for protected subprogram
body
procedure Prot_Subp_Indicator_Bug is
package Synch_Pkg is
type Synch_Interface is synchronized interface;
procedure P (X : out Synch_Interface) is abstract;
procedure Q (X : in out Synch_Interface) is abstract;
end Synch_Pkg;
use Synch_Pkg;
protected type Prot_Type is new Synch_Interface with
procedure P;-- Warning "missing overriding indicator" OK with -gnatyO
overriding -- OK
procedure Q;
end Prot_Type;
protected body Prot_Type is
procedure P is -- Shouldn't get warning about adding overriding indicator
begin
null;
end P;
overriding -- Illegal (but only give a warning when using -gnatd.E)
procedure Q is
begin
null;
end Q;
end Prot_Type;
begin
null;
end Prot_Subp_Indicator_Bug;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Gary Dismukes
* debug.adb: Add case of illegal overriding_indicator for a
protected subprogram body to description of -gnatd.E switch.
* sem_ch6.adb (Verify_Overriding_Indicator): Issue error message
for cases of giving overriding_indicators on protected subprogram
bodies, but change this to a warning if -gnatd.E is enabled. No
longer give a style warning about missing indicators on protected
subprogram bodies.
Index: debug.adb
===
--- debug.adb (revision 210697)
+++ debug.adb (working copy)
@@ -614,6 +614,11 @@
--
-- Errors relating to the new rules about not defining equality
-- too late so that composition of equality can be assured.
+ --
+ -- Errors relating to overriding indicators on protected subprogram
+ -- bodies (not an Ada 2012 incompatibility, but might cause errors
+ -- for existing programs assuming they were legal because GNAT
+ -- formerly allowed them).
-- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in
-- the special mode used by GNATprove.
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 210697)
+++ sem_ch6.adb (working copy)
@@ -2782,6 +2782,16 @@
elsif not Present (Overridden_Operation (Spec_Id)) then
Error_Msg_NE
("subprogram& is not overriding", Body_Spec, Spec_Id);
+
+-- Overriding indicators aren't allowed for protected subprogram
+-- bodies (see the Confirmation in Ada Comment AC95-00213). Change
+-- this to a warning if -gnatd.E is enabled.
+
+elsif Ekind (Scope (Spec_Id)) = E_Protected_Type then
+ Error_Msg_Warn := Error_To_Warning;
+ Error_Msg_N
+ ("
[Ada] Fix error in classification of restriction warnings
Some restriction warnings messages were still being tagged as
[enabled by default] instead of [restriction warning]. The
following program used not to give the warning since it got
incorrectly suppressed (compiled with -gnatj55 -gnatw.d -gnatl)
1. pragma Warnings (Off, "[enabled by default]");
2. pragma Restriction_Warnings
3. (No_Dependence => Ada.Containers);
4. with Ada.Containers;
|
>>> warning: violation of restriction
"No_Dependence => Ada.Containers" at line
3 [restriction warning]
5. procedure Ololo (Unref : Integer) is
6. type String is (A, B, C);
7.
8. procedure P (I, J : in out Integer) is
9. begin
10.if I < J then
11. I := I + 1;
12. P (I, J);
13.end if;
14. end P;
15.
16. J, I : Integer := 10;
17.
18. X, Y : Float := 1.0;
19. begin
20. if X = Y then
21.P (J, I);
22. end if;
23. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Robert Dewar
* errout.ads: Add documentation for use of >*> tag.
* restrict.adb: Make sure we use >*> tag for restriction warnings.
Index: errout.ads
===
--- errout.ads (revision 210697)
+++ errout.ads (working copy)
@@ -312,10 +312,10 @@
--Insertion character < (Less Than: conditional warning message)
-- The character < appearing anywhere in a message is used for a
-- conditional error message. If Error_Msg_Warn is True, then the
- -- effect is the same as ? described above, and in particular << and
- -- &`#", N);
end if;
end Check_Restriction_No_Use_Of_Attribute;
@@ -336,7 +336,7 @@
Error_Msg_Node_1 := Id;
Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
Error_Msg_N
- (" &`#", Id);
end if;
end Check_Restriction_No_Use_Of_Pragma;
@@ -645,7 +645,7 @@
if No_Dependences.Table (J).Warn then
Error_Msg
- ("??violation of restriction `No_Dependence '='> &`#",
+ ("?*?violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
else
Error_Msg
@@ -691,7 +691,7 @@
Error_Msg_Node_1 := Id;
Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
Error_Msg_N
- (" &`#",
Id);
end if;
end Check_Restriction_No_Specification_Of_Aspect;
[Ada] Update SPARK cross references for local packages
Cross references for GNATprove on SPARK code should not use local packages as valid scopes, but instead the enclosing subprogram, which is the meaningful scope to distinguish between local and global variables. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Yannick Moy * lib-xref-spark_specific.adb, lib-xref.ads, lib-xref.adb (Enclosing_Subprogram_Or_Package): Only return a library-level package. Index: lib-xref-spark_specific.adb === --- lib-xref-spark_specific.adb (revision 210697) +++ lib-xref-spark_specific.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, 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- -- @@ -23,10 +23,9 @@ -- -- -- -with SPARK_Xrefs; use SPARK_Xrefs; -with Einfo; use Einfo; -with Nmake; use Nmake; -with Put_SPARK_Xrefs; +with SPARK_Xrefs; use SPARK_Xrefs; +with Einfo; use Einfo; +with Nmake; use Nmake; with GNAT.HTable; @@ -972,7 +971,9 @@ -- Enclosing_Subprogram_Or_Package -- - - function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id is + function Enclosing_Subprogram_Or_Library_Package + (N : Node_Id) return Entity_Id + is Result : Entity_Id; begin @@ -990,13 +991,27 @@ while Present (Result) loop case Nkind (Result) is when N_Package_Specification => - Result := Defining_Unit_Name (Result); - exit; + -- Only return a library-level package + + if Is_Library_Level_Entity (Defining_Entity (Result)) then + Result := Defining_Entity (Result); + exit; + else + Result := Parent (Result); + end if; + when N_Package_Body => - Result := Defining_Unit_Name (Result); - exit; + -- Only return a library-level package + + if Is_Library_Level_Entity (Defining_Entity (Result)) then + Result := Defining_Entity (Result); + exit; + else + Result := Parent (Result); + end if; + when N_Subprogram_Specification => Result := Defining_Unit_Name (Result); exit; @@ -1045,7 +1060,7 @@ end if; return Result; - end Enclosing_Subprogram_Or_Package; + end Enclosing_Subprogram_Or_Library_Package; - -- Entity_Hash -- @@ -1107,7 +1122,7 @@ Create_Heap; end if; -Ref_Scope := Enclosing_Subprogram_Or_Package (N); +Ref_Scope := Enclosing_Subprogram_Or_Library_Package (N); Deref.Ent := Heap; Deref.Loc := Loc; Index: lib-xref.ads === --- lib-xref.ads(revision 210697) +++ lib-xref.ads(working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- @@ -624,8 +624,12 @@ package SPARK_Specific is - function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id; - -- Return the closest enclosing subprogram of package + function Enclosing_Subprogram_Or_Library_Package +(N : Node_Id) return Entity_Id; + -- Return the closest enclosing subprogram of package. Only return a + -- library level package. If the package is enclosed in a subprogram, + -- return the subprogram. This ensures that GNATprove can distinguish + -- local variables from global variables.
[Ada] Implement legality rules for shared volatile variables
This patch implements the rules defined in SPARK 2014 RM section C.6. The rules
forbit certain constructs to be labelled as volatile.
-- Source --
-- shared_variables.ads
package Shared_Variables
with SPARK_Mode => On
is
type T is new Integer
with Volatile; -- OK
type Colour is (Red, Green, Blue)
with Volatile; -- OK
S : Integer
with Volatile; -- OK
type R is record
F1 : Integer;
F2 : Integer with Volatile; -- illegal, SPARK RM C.6(1)
F3 : Boolean;
end record;
type R2 is record
F1 : Integer;
F2 : T; -- illegal, SPARK RM C.6(2)
end record;
type R3 (D : Colour) is record -- illegal, SPARK RM C.6(3)
Intensity : Natural;
end record;
type R4 (D : Boolean) is record
F1 : Integer;
end record with Volatile;-- illegal, SPARK RM C.6(4)
type R5 (D : Boolean := False) is record
F1 : Integer;
end record; -- legal
SV : R5 with Volatile; -- illegal, SPARK RM C.6(4)
type R6 is tagged record
F1 : Integer;
end record with Volatile;-- illegal, SPARK RM C.6(5)
type R7 is tagged record
F1 : Integer;
end record; -- legal
SV2 : R7 with Volatile; -- illegal, SPARK RM C.6(5)
end Shared_Variables;
-- Compilation and output --
$ gcc -c shared_variables.ads
shared_variables.ads:15:07: component "F2" of non-volatile record type "R"
cannot be volatile
shared_variables.ads:15:25: argument of aspect "Volatile" must denote a full
type or object declaration
shared_variables.ads:21:07: component "F2" of non-volatile record type "R2"
cannot be volatile
shared_variables.ads:24:13: discriminant cannot be volatile
shared_variables.ads:28:09: discriminated type "R4" cannot be volatile
shared_variables.ads:36:04: discriminated object "SV" cannot be volatile
shared_variables.ads:38:09: tagged type "R6" cannot be volatile
shared_variables.ads:46:04: tagged object "SV2" cannot be volatile
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Hristian Kirtchev
* freeze.adb (Freeze_Record_Type): Ensure that a discriminated
or a tagged type is not labelled as volatile. Ensure that a
non-volatile type has no volatile components.
* sem_ch3.adb (Analyze_Object_Contract): Add local constant
Obj_Typ. Code reformatting. Ensure that a discriminated or
tagged object is not labelled as volatile.
* sem_prag.adb (Process_Atomic_Shared_Volatile): Ensure that
pragma Volatile applies to a full type declaration or an object
declaration when SPARK mode is on.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 210695)
+++ sem_ch3.adb (working copy)
@@ -2980,12 +2980,13 @@
-
procedure Analyze_Object_Contract (Obj_Id : Entity_Id) is
- AR_Val : Boolean := False;
- AW_Val : Boolean := False;
- ER_Val : Boolean := False;
- EW_Val : Boolean := False;
- Prag : Node_Id;
- Seen : Boolean := False;
+ Obj_Typ : constant Entity_Id := Etype (Obj_Id);
+ AR_Val : Boolean := False;
+ AW_Val : Boolean := False;
+ ER_Val : Boolean := False;
+ EW_Val : Boolean := False;
+ Prag: Node_Id;
+ Seen: Boolean := False;
begin
if Ekind (Obj_Id) = E_Constant then
@@ -3008,26 +3009,43 @@
-- they are not standard Ada legality rules.
if SPARK_Mode = On then
+if Is_SPARK_Volatile_Object (Obj_Id) then
--- A non-volatile object cannot have volatile components
--- (SPARK RM 7.1.3(7)).
+ -- The declaration of a volatile object must appear at the
+ -- library level (SPARK RM 7.1.3(7), C.6(6)).
-if not Is_SPARK_Volatile_Object (Obj_Id)
- and then Has_Volatile_Component (Etype (Obj_Id))
-then
- Error_Msg_N
- ("non-volatile variable & cannot have volatile components",
- Obj_Id);
+ if not Is_Library_Level_Entity (Obj_Id) then
+ Error_Msg_N
+("volatile variable & must be declared at library level",
+ Obj_Id);
--- The declaration of a volatile object must appear at the library
--- level.
+ -- An object of a discriminated type cannot be volatile
+ -- (SPARK RM C.6(4)).
-elsif Is_SPARK_Volatile_Object (Obj_Id)
- and then not Is_Library_Level_Entity (Obj_Id)
-then
- Error_Msg_N
- ("volatile variable & must be declared at library level "
- & "(SPARK RM 7.1.3(5))", Obj_Id);
+ elsif Has_Discri
[Ada] PR ada/9535 improved consistency of stream primitives for datagram sockets
This change implements a suggested improvement to the behaviour of
stream primitives for streams backed by datagram sockets: a Read or
Write call now corresponds to exactly one Receive_Socket or Send_Socket call.
Test case:
$ gnatmake -q udp_stream
$ ./udp_stream
Got 5 characters: <>
with Ada.Streams; use Ada.Streams;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Sockets; use GNAT.Sockets;
procedure UDP_Stream is
A : Sock_Addr_Type;
S1, S2 : Socket_Type;
begin
Create_Socket (S1, Family_Inet, Socket_Datagram);
A.Addr := Loopback_Inet_Addr;
A.Port := Any_Port;
Bind_Socket (S1, A);
A := Get_Socket_Name (S1);
Create_Socket (S2, Family_Inet, Socket_Datagram);
Connect_Socket (S2, A);
String'Write (Stream (S2, A), "hello");
declare
SEA : Stream_Element_Array (1 .. 16);
Last : Stream_Element_Offset;
Str : String (1 .. 16);
for Str'Address use SEA'Address;
pragma Import (Ada, Str);
begin
Read (Stream (S1, A).all, SEA, Last);
Put_Line
("Got" & Last'Img & " characters: <<"
& Str (1 .. Integer (Last)) & ">>");
end;
end UDP_Stream;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Thomas Quinot
* g-socket.adb (Read and Write for Datagram_Socket_Stream_Type):
Provide a behaviour more consistent with underlying datagram
socket: do not attempt to loop over Send_Socket/Receive_Socket
iterating along the buffer.
Index: g-socket.adb
===
--- g-socket.adb(revision 210687)
+++ g-socket.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2013, AdaCore --
+-- Copyright (C) 2001-2014, AdaCore --
-- --
-- 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- --
@@ -244,13 +244,6 @@
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array);
- procedure Stream_Write
- (Socket : Socket_Type;
- Item : Ada.Streams.Stream_Element_Array;
- To : access Sock_Addr_Type);
- -- Common implementation for the Write operation of Datagram_Socket_Stream_
- -- Type and Stream_Socket_Stream_Type.
-
procedure Wait_On_Socket
(Socket : Socket_Type;
For_Read : Boolean;
@@ -1732,27 +1725,12 @@
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset)
is
- First : Ada.Streams.Stream_Element_Offset := Item'First;
- Index : Ada.Streams.Stream_Element_Offset := First - 1;
- Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
-
begin
- loop
- Receive_Socket
- (Stream.Socket,
-Item (First .. Max),
-Index,
-Stream.From);
-
- Last := Index;
-
- -- Exit when all or zero data received. Zero means that the socket
- -- peer is closed.
-
- exit when Index < First or else Index = Max;
-
- First := Index + 1;
- end loop;
+ Receive_Socket
+(Stream.Socket,
+ Item,
+ Last,
+ Stream.From);
end Read;
--
@@ -2419,43 +2397,6 @@
return Stream_Access (S);
end Stream;
- --
- -- Stream_Write --
- --
-
- procedure Stream_Write
- (Socket : Socket_Type;
- Item : Ada.Streams.Stream_Element_Array;
- To : access Sock_Addr_Type)
- is
- First : Ada.Streams.Stream_Element_Offset;
- Index : Ada.Streams.Stream_Element_Offset;
- Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
-
- begin
- First := Item'First;
- Index := First - 1;
- while First <= Max loop
- Send_Socket (Socket, Item (First .. Max), Index, To);
-
- -- Exit when all or zero data sent. Zero means that the socket has
- -- been closed by peer.
-
- exit when Index < First or else Index = Max;
-
- First := Index + 1;
- end loop;
-
- -- For an empty array, we have First > Max, and hence Index >= Max (no
- -- error, the loop above is never executed). After a successful send,
- -- Index = Max. The only remaining case, Index < Max, is therefore
- -- always an actual send failure.
-
- if Index < Max then
- Raise_Socket_Error (Socket_Errno);
- end if;
- end Stream_Write;
-
--
-- To_C --
--
@@ -2695,8 +2636,20 @@
(Stream : in
[Ada] Fix error of not diagnosing bad body with non-standard file names
If Source_File_Name pragmas with patterns were used to specify a non-
standard naming scheme, then the compiler would fail to diagnose an
attempt to compile a spec which did not need a body when in fact a
body file was present.
Given a gnat.adc file containing:
1. pragma Source_File_Name_Project
2. (Spec_File_Name => "*.1.ada",
3.Casing => lowercase,
4.Dot_Replacement => "-");
5. pragma Source_File_Name_Project
6. (Body_File_Name => "*.2.ada",
7.Casing => lowercase,
8.Dot_Replacement => "-");
where pkg.1.ada contains
1. package Pkg is end;
and pkg.2.ada contains
1. package body Pkg is end;
the compiling the spec using gcc -c -x ada pkg.1.ada generates
1. package Pkg is end;
|
>>> package "Pkg" does not allow a body
>>> remove incorrect body in file "pkg.2.ada"
Previously this message was not given in this case
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Robert Dewar
* gnat1drv.adb (Check_Bad_Body): Use Source_File_Is_Body to
simplify the needed test, and also deal with failure to catch
situations with non-standard names.
* sinput-l.ads, sinput-l.adb (Source_File_Is_No_Body): New function
(Source_File_Is_Subunit): Removed, no longer used.
Index: gnat1drv.adb
===
--- gnat1drv.adb(revision 210687)
+++ gnat1drv.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -633,7 +633,6 @@
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body name
- -- (but how can we have a body name here???)
if not Is_Body_Name (Sname) then
Sname := Get_Body_Name (Sname);
@@ -651,19 +650,15 @@
-- to include both in a partition, this is diagnosed at bind time. In
-- Ada 83 mode this is not a warning case.
- -- Note: if weird file names are being used, we can have a situation
- -- where the file name that supposedly contains body in fact contains
- -- a spec, or we can't tell what it contains. Skip the error message
- -- in these cases.
+ -- Note that in general we do not give the message if the file in
+ -- question does not look like a body. This includes weird cases,
+ -- but in particular means that if the file is just a No_Body pragma,
+ -- then we won't give the message (that's the whole point of this
+ -- pragma, to be used this way and to cause the body file to be
+ -- ignored in this context).
- -- Also ignore body that is nothing but pragma No_Body; (that's the
- -- whole point of this pragma, to be used this way and to cause the
- -- body file to be ignored in this context).
-
if Src_Ind /= No_Source_File
- and then Get_Expected_Unit_Type (Fname) = Expect_Body
- and then not Source_File_Is_Subunit (Src_Ind)
- and then not Source_File_Is_No_Body (Src_Ind)
+ and then Source_File_Is_Body (Src_Ind)
then
Errout.Finalize (Last_Call => False);
@@ -693,8 +688,8 @@
else
-- For generic instantiations, we never allow a body
- if Nkind (Original_Node (Unit (Main_Unit_Node)))
- in N_Generic_Instantiation
+ if Nkind (Original_Node (Unit (Main_Unit_Node))) in
+N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for $$ does not allow a body");
Index: sinput-l.adb
===
--- sinput-l.adb(revision 210687)
+++ sinput-l.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
--
[Ada] Do not complain about restricted references within defining units
Restrictions No_Abort_Statements and No_Dynamic_Attachment follow exactly the RM rule which forbids any references to certain entities. But this should not apply to the units in which these entities are declared, since otherwise, for example, a pragma Inline for one of these entities is a violation of this restriction. This patch avoids complaining about any reference to restricted entities from within their own extended units. Given a gnat.adc file containing pragma Restrictions (No_Abort_Statements); with this patch, you can compile s-taside.ads using -gnatc -gnatg and the compilation does not flag a restriction violation. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar * sem_util.adb (Set_Entity_With_Checks): Don't complain about references to restricted entities within the units in which they are declared. Index: sem_util.adb === --- sem_util.adb(revision 210695) +++ sem_util.adb(working copy) @@ -15877,6 +15877,11 @@ if Restriction_Check_Required (No_Abort_Statements) and then (Is_RTE (Val, RE_Abort_Task)) + +-- A special extra check, don't complain about a reference from within +-- the Ada.Task_Identification package itself! + +and then not In_Same_Extended_Unit (N, Val) then Check_Restriction (No_Abort_Statements, Post_Node); end if; @@ -15892,6 +15897,10 @@ Is_RTE (Val, RE_Exchange_Handler) or else Is_RTE (Val, RE_Detach_Handler) or else Is_RTE (Val, RE_Reference)) +-- A special extra check, don't complain about a reference from within +-- the Ada.Interrupts package itself! + +and then not In_Same_Extended_Unit (N, Val) then Check_Restriction (No_Dynamic_Attachment, Post_Node); end if;
[Ada] Add missing entities to Stand.Tree_Read and Stand.Tree_Write
Several entities were not written by Tree_Write and correspondingly not set by Tree_Read. Theoretically this could affect ASIS if it used any routines needing these entities, but we have never observed any issues in this area, so it is likely this is just a latent bug with no observable functional effect. No test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar * stand.adb (Tree_Read): Read missing entities. (Tree_Write): Write missing entities. Index: stand.adb === --- stand.adb (revision 210687) +++ stand.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc.-- +-- Copyright (C) 1992-2014, 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- -- @@ -29,6 +29,7 @@ -- -- -- +with Elists; use Elists; with System; use System; with Tree_IO; use Tree_IO; @@ -46,9 +47,32 @@ Tree_Read_Int (Int (Standard_Package_Node)); Tree_Read_Int (Int (Last_Standard_Node_Id)); Tree_Read_Int (Int (Last_Standard_List_Id)); + + Tree_Read_Int (Int (Boolean_Literals (False))); + Tree_Read_Int (Int (Boolean_Literals (True))); + Tree_Read_Int (Int (Standard_Void_Type)); Tree_Read_Int (Int (Standard_Exception_Type)); Tree_Read_Int (Int (Standard_A_String)); + Tree_Read_Int (Int (Standard_A_Char)); + Tree_Read_Int (Int (Standard_Debug_Renaming_Type)); + + -- Deal with Predefined_Float_Types, which is an Elist. We wrote the + -- entities out in sequence, terminated by an Empty entry. + + declare + Elmt : Entity_Id; + begin + Predefined_Float_Types := New_Elmt_List; + loop +Tree_Read_Int (Int (Elmt)); +exit when Elmt = Empty; +Append_Elmt (Elmt, Predefined_Float_Types); + end loop; + end; + + -- Remainder of special entities + Tree_Read_Int (Int (Any_Id)); Tree_Read_Int (Int (Any_Type)); Tree_Read_Int (Int (Any_Access)); @@ -59,10 +83,12 @@ Tree_Read_Int (Int (Any_Discrete)); Tree_Read_Int (Int (Any_Fixed)); Tree_Read_Int (Int (Any_Integer)); + Tree_Read_Int (Int (Any_Modular)); Tree_Read_Int (Int (Any_Numeric)); Tree_Read_Int (Int (Any_Real)); Tree_Read_Int (Int (Any_Scalar)); Tree_Read_Int (Int (Any_String)); + Tree_Read_Int (Int (Raise_Type)); Tree_Read_Int (Int (Universal_Integer)); Tree_Read_Int (Int (Universal_Real)); Tree_Read_Int (Int (Universal_Fixed)); @@ -70,12 +96,12 @@ Tree_Read_Int (Int (Standard_Integer_16)); Tree_Read_Int (Int (Standard_Integer_32)); Tree_Read_Int (Int (Standard_Integer_64)); - Tree_Read_Int (Int (Standard_Unsigned_64)); Tree_Read_Int (Int (Standard_Short_Short_Unsigned)); Tree_Read_Int (Int (Standard_Short_Unsigned)); Tree_Read_Int (Int (Standard_Unsigned)); Tree_Read_Int (Int (Standard_Long_Unsigned)); Tree_Read_Int (Int (Standard_Long_Long_Unsigned)); + Tree_Read_Int (Int (Standard_Unsigned_64)); Tree_Read_Int (Int (Abort_Signal)); Tree_Read_Int (Int (Standard_Op_Rotate_Left)); Tree_Read_Int (Int (Standard_Op_Rotate_Right)); @@ -96,9 +122,34 @@ Tree_Write_Int (Int (Standard_Package_Node)); Tree_Write_Int (Int (Last_Standard_Node_Id)); Tree_Write_Int (Int (Last_Standard_List_Id)); + + Tree_Write_Int (Int (Boolean_Literals (False))); + Tree_Write_Int (Int (Boolean_Literals (True))); + Tree_Write_Int (Int (Standard_Void_Type)); Tree_Write_Int (Int (Standard_Exception_Type)); Tree_Write_Int (Int (Standard_A_String)); + Tree_Write_Int (Int (Standard_A_Char)); + Tree_Write_Int (Int (Standard_Debug_Renaming_Type)); + + -- Deal with Predefined_Float_Types, which is an Elist. Write the + -- entities out in sequence, terminated by an Empty entry. + + declare + Elmt : Elmt_Id; + + begin + Elmt := First_Elmt (Predefined_Float_Types); + while Present (Elmt) loop +Tree_Write_Int (Int (Node (Elmt))); +Next_Elmt (Elmt); + end loop; + + Tree_Write_Int (Int (Empty)); + end; + + -- Remainder of special entries +
[Ada] Allow warning tag in pragma Warnings (Off, string)
This patch allows the use of a warning tag as the second parameter of a pragma Warnings (Off\On, ...) pragma. The effect is to control all error messages in that category. This tag may be either [-gnatw?] for a particular category of errors, or [restriction warning] to cover all restriction warnings, or [enabled by default] to deal with all other warnings that are set by default. The following test is compiled with -gnatj55 -gnatl 1. pragma Restriction_Warnings (No_Wide_Characters); 2. package RWarnTag2 is 3.pragma Warnings (Off, "[restriction warning]"); 4.Y : Wide_Wide_Character := 'Y'; 5.pragma Warnings (On, "[restriction warning]"); 6.X : Wide_Wide_Character := 'X'; | >>> warning: violation of restriction "No_Wide_Characters" at line 1 7. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar * errout.adb, erroutc.adb, erroutc.ads: Allow warning tag in pragma Warnings (Off, string). Index: errout.adb === --- errout.adb (revision 210693) +++ errout.adb (working copy) @@ -1339,14 +1339,16 @@ Cur := First_Error_Msg; while Cur /= No_Error_Msg loop declare -CE : Error_Msg_Object renames Errors.Table (Cur); +CE : Error_Msg_Object renames Errors.Table (Cur); +Tag : constant String := Get_Warning_Tag (Cur); begin if (CE.Warn and not CE.Deleted) - and then (Warning_Specifically_Suppressed (CE.Sptr, CE.Text) /= + and then + (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /= No_String - or else -Warning_Specifically_Suppressed (CE.Optr, CE.Text) /= + or else +Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /= No_String) then Delete_Warning (Cur); Index: erroutc.adb === --- erroutc.adb (revision 210693) +++ erroutc.adb (working copy) @@ -1457,7 +1457,8 @@ function Warning_Specifically_Suppressed (Loc : Source_Ptr; - Msg : String_Ptr) return String_Id + Msg : String_Ptr; + Tag : String) return String_Id is begin -- Loop through specific warning suppression entries @@ -1473,7 +1474,9 @@ if SWE.Config or else (SWE.Start <= Loc and then Loc <= SWE.Stop) then - if Matches (Msg.all, SWE.Msg.all) then + if Matches (Msg.all, SWE.Msg.all) + or else Matches (Tag, SWE.Msg.all) + then SWE.Used := True; return SWE.Reason; end if; Index: erroutc.ads === --- erroutc.ads (revision 210693) +++ erroutc.ads (working copy) @@ -556,12 +556,14 @@ function Warning_Specifically_Suppressed (Loc : Source_Ptr; - Msg : String_Ptr) return String_Id; + Msg : String_Ptr; + Tag : String) return String_Id; -- Determines if given message to be posted at given location is suppressed -- by specific ON/OFF Warnings pragmas specifying this particular message. -- If the warning is not suppressed then No_String is returned, otherwise -- the corresponding warning string is returned (or the null string if no - -- Warning argument was present in the pragma). + -- Warning argument was present in the pragma). Tag is the error message + -- tag for the message in question. function Warning_Treated_As_Error (Msg : String) return Boolean; -- Returns True if the warning message Msg matches any of the strings
[Ada] Clearer documentation of -gnatw.g and -gnatyg switches
This patch provides more precise documentation of the GNAT mode warning
switch -gnatw.g and the GNAT mode style switch -gnatyg, in both the users
guide and the usage information. Documentation change only, no test needed.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Robert Dewar
* gnat_ugn.texi: Clearly document -gnatw.g (GNAT warnings).
Clearly document -gnatyg (GNAT style switches).
* usage.adb: Add line line for -gnatw.g (GNAT warnings) More
detail for line for -gnatyg (GNAT style switches) -gnatw.d/D is
available for VMS after all.
* warnsw.adb: Reorganize to eliminate duplicated code
(Restore_Warnings): Add a couple of missing entries
(Save_Warnings): Add a couple of missing entries.
* warnsw.ads: Add missing entries to Warning_Record (not clear
what the impact is).
Index: usage.adb
===
--- usage.adb (revision 210687)
+++ usage.adb (working copy)
@@ -6,7 +6,7 @@
-- --
--B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -121,8 +121,8 @@
Write_Eol;
-- Individual lines for switches. Write_Switch_Char outputs fourteen
- -- characters, so the remaining message is allowed to be a maximum
- -- of 65 characters to be comfortable in an 80 character window.
+ -- characters, so the remaining message is allowed to be a maximum of
+ -- 65 characters to be comfortable in an 80 character window.
-- Line for -gnata switch
@@ -494,16 +494,8 @@
Write_Line (".C* turn off warnings for unrepped components");
Write_Line ("dturn on warnings for implicit dereference");
Write_Line ("D* turn off warnings for implicit dereference");
-
- -- Switches -gnatw.d/w.D not available on VMS
-
- if not OpenVMS_On_Target then
- Write_Line
-(".d turn on tagging of warnings with -gnatw switch");
- Write_Line
-(".D* turn off tagging of warnings with -gnatw switch");
- end if;
-
+ Write_Line (".d turn on tagging of warnings with -gnatw switch");
+ Write_Line (".D* turn off tagging of warnings with -gnatw switch");
Write_Line ("etreat all warnings (but not info) as errors");
Write_Line (".e turn on every optional info/warning " &
"(no exceptions)");
@@ -511,6 +503,7 @@
Write_Line ("F* turn off warnings for unreferenced formal");
Write_Line ("g*+ turn on warnings for unrecognized pragma");
Write_Line ("Gturn off warnings for unrecognized pragma");
+ Write_Line (".g turn on GNAT warnings, same as Aao.sI.C.V.X");
Write_Line ("hturn on warnings for hiding declarations");
Write_Line ("H* turn off warnings for hiding declarations");
Write_Line (".h turn on warnings for holes in records");
@@ -640,7 +633,7 @@
Write_Line ("dcheck no DOS line terminators");
Write_Line ("echeck end/exit labels present");
Write_Line ("fcheck no form feeds/vertical tabs in source");
- Write_Line ("gcheck standard GNAT style rules");
+ Write_Line ("gcheck standard GNAT style rules, same as ydISux");
Write_Line ("hcheck no horizontal tabs in source");
Write_Line ("icheck if-then layout");
Write_Line ("Icheck mode in");
Index: gnat_ugn.texi
===
--- gnat_ugn.texi (revision 210691)
+++ gnat_ugn.texi (working copy)
@@ -4018,7 +4018,7 @@
applications programs, it is intended only for use by the compiler
and its run-time library. For documentation, see the GNAT sources.
Note that @option{^-gnatg^/GNAT_INTERNAL^} implies
-@option{^-gnatwae^/WARNINGS=ALL,ERRORS^} and
+@option{^-gnatw.ge^/WARNINGS=GNAT,ERRORS^} and
@option{^-gnatyg^/STYLE_CHECKS=GNAT^}
so that all standard warnings and all standard style options are turned on.
All warnings and style messages are treated as errors.
@@ -5167,6 +5167,14 @@
@cindex @option{-gnatwG} (@command{gcc})
This switch suppresses warnings for unrecognized pragmas.
+@item -gnatw.g
+@emph{Warnings used for GNAT sources}
+@cindex @option{-gnatw.g} (@command{gcc})
+This switch se
[Ada] Tag restriction warning messages
Restriction warning messages are now tagged [restriction warning]
if -gnatw.d is used, instead of [enabled by default]. This new
tag can be used in pragma Warning_As_Errors. The following is
compiled with -gnatw.d -gnatj50 -gnatl
1. pragma Warning_As_Error ("[restriction warning]");
2. pragma Restriction_Warnings (No_Wide_Characters);
3. package RWarnTag is
4.X : Wide_Wide_Character := 'X';
|
>>> error: violation of restriction
"No_Wide_Characters" at line 2
[restriction warning]
[warning-as-error]
5. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Robert Dewar
* errout.adb (Set_Msg_Insertion_Warning): Handle ?*? (restriction
warning) case.
* errout.ads: Document ?*? (restriction warning) insertion.
* erroutc.adb (Get_Warning_Tag): Deal with ?*? (restriction
warning) case.
* erroutc.ads: Document use of * for restriction warning tag.
* restrict.adb (Restriction_Msg): Tag with ?*? instead of ??.
Index: errout.adb
===
--- errout.adb (revision 210687)
+++ errout.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -2764,7 +2764,9 @@
elsif P + 1 <= Text'Last
and then (Text (P) in 'a' .. 'z'
or else
- Text (P) in 'A' .. 'Z')
+ Text (P) in 'A' .. 'Z'
+ or else
+ Text (P) = '*')
and then Text (P + 1) = C
then
Warning_Msg_Char := Text (P);
Index: errout.ads
===
--- errout.ads (revision 210687)
+++ errout.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -60,10 +60,12 @@
-- Exception raised if Raise_Exception_On_Error is true
Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch;
- -- If this is set True, then the ??/?x?/?X? sequences in error messages
- -- are active (see errout.ads for details). If this switch is False, then
- -- these sequences are ignored (i.e. simply equivalent to a single ?). The
- -- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
+ -- If this is set True, then the ??/?*?/?x?/?X? sequences in error messages
+ -- generate appropriate tags for the output error messages. If this switch
+ -- is False, then these sequences are still recognized (for the purposes
+ -- of implementing pragmas Warnings (Off,..) and Warning_As_Pragma(...) but
+ -- do not result in adding the error message tag. The -gnatw.d switch sets
+ -- this flag True, -gnatw.D sets this flag False.
---
-- Suppression of Error Messages --
@@ -281,7 +283,7 @@
-- messages, and the usual style is to include it, since it makes it
-- clear that the continuation is part of a warning message.
--
- -- Note: this usage is obsolete, use ??, ?x? or ?X? instead to specify
+ -- Note: this usage is obsolete, use ?? ?*? ?x? ?X? instead to specify
-- the string to be added when Warn_Doc_Switch is set to True. If this
-- switch is True, then for simple ? messages it has no effect. This
-- simple form is to ease transition and will be removed later.
@@ -302,6 +304,11 @@
-- letter corresponding to the lower case letter x in the message.
-- For continuations, use this on each continuation message.
+ --Insertion character ?*? (restriction warning)
+ -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+ -- "[restriction warning]" at the en
[Ada] Fix possible overflow in table handling
The Reallocate procedures in g-htable.adb and g-dyntab.adb are subject to problems with possible intermediate overflow. This has never been reported to cause problems, but in theory it could cause performance degradation, so it is now fixed. No test, because too much trouble to construct, and we have never had an instance of this reported. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar * g-table.adb, g-dyntab.adb (Reallocate): Fix possible overflow in computing new table size. Index: g-table.adb === --- g-table.adb (revision 210687) +++ g-table.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, AdaCore -- +-- Copyright (C) 1998-2014, AdaCore -- -- -- -- 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- -- @@ -196,21 +196,25 @@ procedure Reallocate is - New_Size : size_t; + New_Size : size_t; + New_Length : Long_Long_Integer; begin if Max < Last_Val then pragma Assert (not Locked); + -- Now increment table length until it is sufficiently large. Use + -- the increment value or 10, which ever is larger (the reason + -- for the use of 10 here is to ensure that the table does really + -- increase in size (which would not be the case for a table of + -- length 10 increased by 3% for instance). Do the intermediate + -- calculation in Long_Long_Integer to avoid overflow. + while Max < Last_Val loop - --- Increase length using the table increment factor, but make --- sure that we add at least ten elements (this avoids a loop --- for silly small increment values) - -Length := Integer'Max -(Length * (100 + Table_Increment) / 100, - Length + 10); +New_Length := + Long_Long_Integer (Length) * +(100 + Long_Long_Integer (Table_Increment)) / 100; +Length := Integer'Max (Integer (New_Length), Length + 10); Max := Min + Length - 1; end loop; end if; Index: g-dyntab.adb === --- g-dyntab.adb(revision 210687) +++ g-dyntab.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2013, AdaCore -- +-- Copyright (C) 2000-2014, AdaCore -- -- -- -- 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- -- @@ -187,13 +187,24 @@ begin if T.P.Max < T.P.Last_Val then + + -- Now increment table length until it is sufficiently large. Use + -- the increment value or 10, which ever is larger (the reason + -- for the use of 10 here is to ensure that the table does really + -- increase in size (which would not be the case for a table of + -- length 10 increased by 3% for instance). Do the intermediate + -- calculation in Long_Long_Integer to avoid overflow. + while T.P.Max < T.P.Last_Val loop -New_Length := T.P.Length * (100 + Table_Increment) / 100; +New_Length := + Integer +(Long_Long_Integer (T.P.Length) * + (100 + Long_Long_Integer (Table_Increment)) / 100); if New_Length > T.P.Length then T.P.Length := New_Length; else - T.P.Length := T.P.Length + 1; + T.P.Length := T.P.Length + 10; end if; T.P.Max := Min + T.P.Length - 1;
[Ada] Detect illegal component of dereference of access-to-constant
This patch detects an error that was previously undetected. In particular, it
is illegal to rename a subcomponent of an object designated by an
access-to-constant value if that subcomponent depends on discriminants.
The following test should get an error:
% gnatmake -f -q acc_const_test.adb
acc_const_test.adb:17:46: illegal renaming of discriminant-dependent component
gnatmake: "acc_const_test.adb" compilation error
%
with Ada.Text_IO; use Ada.Text_IO;
procedure Acc_Const_Test is
subtype Int is Integer range 1..100;
type Desig (Discrim : Int := 1) is
record
Discrim_Dependent : String (1..Discrim);
end record;
type Ref_Const is access constant Desig;
Var : aliased Desig := (Discrim => 4, Discrim_Dependent => "abcd");
Ref_Const_Obj : Ref_Const := Var'Access;
Char : Character renames Ref_Const_Obj.all.Discrim_Dependent(4);
-- Illegal in Ada 2005.
begin
Var := (Discrim => 1, Discrim_Dependent => "X");
-- Raises C_E in Ada 95.
Put_Line ("Char = " & Char);
end Acc_Const_Test;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Bob Duff
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object):
This was returning False if the Object is a constant view. Fix
it to return True in that case, because it might be a view of
a variable.
(Has_Discriminant_Dependent_Constraint): Fix latent
bug; this function was crashing when passed a discriminant.
Index: sem_util.adb
===
--- sem_util.adb(revision 210689)
+++ sem_util.adb(working copy)
@@ -7300,39 +7300,46 @@
(Comp : Entity_Id) return Boolean
is
Comp_Decl : constant Node_Id := Parent (Comp);
- Subt_Indic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp_Decl));
+ Subt_Indic : Node_Id;
Constr : Node_Id;
Assn : Node_Id;
begin
- if Nkind (Subt_Indic) = N_Subtype_Indication then
- Constr := Constraint (Subt_Indic);
+ -- Discriminants can't depend on discriminants
- if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
-Assn := First (Constraints (Constr));
-while Present (Assn) loop
- case Nkind (Assn) is
- when N_Subtype_Indication |
- N_Range |
- N_Identifier
- =>
- if Depends_On_Discriminant (Assn) then
-return True;
- end if;
+ if Ekind (Comp) = E_Discriminant then
+ return False;
- when N_Discriminant_Association =>
- if Depends_On_Discriminant (Expression (Assn)) then
-return True;
- end if;
+ else
+ Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
- when others =>
- null;
+ if Nkind (Subt_Indic) = N_Subtype_Indication then
+Constr := Constraint (Subt_Indic);
- end case;
+if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
+ Assn := First (Constraints (Constr));
+ while Present (Assn) loop
+ case Nkind (Assn) is
+ when N_Subtype_Indication |
+ N_Range |
+ N_Identifier
+ =>
+if Depends_On_Discriminant (Assn) then
+ return True;
+end if;
- Next (Assn);
-end loop;
+ when N_Discriminant_Association =>
+if Depends_On_Discriminant (Expression (Assn)) then
+ return True;
+end if;
+
+ when others =>
+null;
+ end case;
+
+ Next (Assn);
+ end loop;
+end if;
end if;
end if;
@@ -9740,11 +9747,6 @@
function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean
is
- P : Node_Id;
- Prefix_Type : Entity_Id;
- P_Aliased : Boolean := False;
- Comp: Entity_Id;
-
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp is declared within a variant part
@@ -9759,17 +9761,41 @@
return Nkind (Parent (Comp_List)) = N_Variant;
end Is_Declared_Within_Variant;
+ P : Node_Id;
+ Prefix_Type : Entity_Id;
+ P_Aliased : Boolean := False;
+ Comp: Entity_Id;
+
+ Deref : Node_Id := Object;
+ -- Dereference node, in something like X.all.Y(2)
+
-- Start of processing for Is_Dependent_Component
[Ada] Handling of deferred references with nested prefixed calls
When handling deferred references, if an actual that is the prefix of an enclosing prefixed call has been rewritten, we must use Nkind and Sloc to identify the corresponding formal. The First_Named_Actual of the enclosing call may be meaningless after the surrounding expansion. No simple example available. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Ed Schonberg * sem_util.adb (Find_Actual): If an actual that is the prefix of an enclosing prefixed call has been rewritten, use Nkind and Sloc to identify the corresponding formal, when handling deferred references. Index: sem_util.adb === --- sem_util.adb(revision 210687) +++ sem_util.adb(working copy) @@ -5518,6 +5518,16 @@ while Present (Formal) and then Present (Actual) loop if Actual = N then return; + +-- An actual that is the prefix in a prefixed call may have +-- been rewritten in the call, after the deferred reference +-- was collected. Check if sloc and kinds match. + +elsif Sloc (Actual) = Sloc (N) + and then Nkind (Actual) = Nkind (N) +then + return; + else Actual := Next_Actual (Actual); Formal := Next_Formal (Formal);
[Ada] Add usage line for gnatmake switch -d
A new line is added in the gnatmake usage for switch -d:
-dDisplay compilation progress
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-05-21 Vincent Celier
* makeusg.adb: Add switch -d to usage.
Index: makeusg.adb
===
--- makeusg.adb (revision 210687)
+++ makeusg.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
@@ -86,6 +86,11 @@
"invoke compiler with mapping file mapp");
Write_Eol;
+ -- Line for -d
+
+ Write_Str (" -d Display compilation progress");
+ Write_Eol;
+
-- Line for -D
Write_Str (" -D dir Specify dir as the object directory");
Re: [PATCH] Add support for GNU/Hurd in gnat-4.9
> > I think the majority of work has bee done, Now that patch will change > > slightly for every missing feature added to Hurd. > > Then it's all good, it's a matter of what I said above. Don't forget also the part where general changes are done in GNAT which require update to target specific files: these typically require someone to regularly test each port to detect any missing update, and report/fix them, even if GNU/Hurd hasn't changed itself. Arno
Re: [PATCH] Add support for GNU/Hurd in gnat-4.9
> > That's actually the biggest concern when people submit a new port: they > > submit it, get it approved, commit it and then are no longer available > > for any maintenance when these files need to be updated/become outdated/ > > no longer compile or run. > > I can try to do that in the near future, then somebody else can take > over. I think maybe Thomas have an opinion about this being a Hurd > developer and a GNU person at the same time. > > Updated patch attached, OK now? No, there are still code commented out, and we need to resolve the above point first. Arno
Re: [PATCH] Add support for GNU/Hurd in gnat-4.9
> Do you want me to remove all GNU/Hurd specific header file info? No, I want you to remove commented out code, such as: > +-- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal > +-- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal > +-- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal Also, can you clarify who will be in charge of maintaining these files? That's actually the biggest concern when people submit a new port: they submit it, get it approved, commit it and then are no longer available for any maintenance when these files need to be updated/become outdated/ no longer compile or run. Arno
Re: [PATCH] Add support for GNU/Hurd in gnat-4.9
> The build went fine. Is something still missing? We never keep commented out code, except with a ??? comment explaining why. We don't use 'FIXME', we use ??? instead. Also, some of the comments seem to be copy/paste from freebsd, which is likely not appropriate for GNU Hurd, so need to be revised. The header is wrong: it should be GPLv3+, not GPLv2+ Also: > + -- 1_024 == 1024?? Remove this comment. Yes, 1_024 is the same as 1024 in Ada. Arno
Re: [ada, build] Ignore cp -p failures during Ada make install
> It seems to me that (as already done in one of three cases in the > install-gnatlib target) $(INSTALL_DATA_DATE) errors should be ignored, > to allow for such a case. > > The following patch does just that and allowed the make install to > complete. > > Ok for mainline? No, it's not OK to ignore all such errors, and the permissions should really be preserved, so such error really musn't be ignored. Arno
Re: [RFC] Add aarch64 support for ada
The Makfile.in and init.c changes are OK. The types.h change is likely more controversial and may be problematic, I'll let Eric comment. > + system.ads > IMO, this should really be called system-linux-lp64.ads, and should > be usable for any 64-bit target that uses full ieee floating point, > which is all of them. Well, in our experience, each time we've tried to share system files, this came back and bit us at some point. But I do not know the aarch64 architecture to comment on this specific case. Arno
Re: Please revert the patches in bug #54040 and #59346 and special case x32
> What do you think, Arno? I think that the POSIX breakage (and its fallout for > the other Unices) is ugly and worth the additional complication. Yes, your patch looks good to me. Arno
[Ada] PR ada/60411
This change enables ZCX on armel linux, and should fix PR ada/60411, at least for the native part reported in comment #1 PR ada/60411 * system-linux-armel.ads (Backend_Overflow_Checks): Set to True. (Support_64_Bit_Divides): Removed, no longer used. (ZCX_By_Default): Enabled. Index: system-linux-armel.ads === --- system-linux-armel.ads (revision 208067) +++ system-linux-armel.ads (working copy) @@ -7,7 +7,7 @@ -- S p e c -- --(GNU-Linux/ARMEL Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -124,7 +124,7 @@ -- of the individual switch values. Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; Command_Line_Args : constant Boolean := True; Configurable_Run_Time : constant Boolean := False; Denorm: constant Boolean := True; @@ -139,7 +139,6 @@ Stack_Check_Default : constant Boolean := False; Stack_Check_Probes: constant Boolean := True; Stack_Check_Limits: constant Boolean := False; - Support_64_Bit_Divides: constant Boolean := True; Support_Aggregates: constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; @@ -147,6 +146,6 @@ Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default: constant Boolean := False; + ZCX_By_Default: constant Boolean := True; end System;
[Ada] Better enforcement of No_Dynamic_Attachment/No_Abort_Statements
No_Dynamic_Attachment is now enforced in -gnatc mode, and includes checking for any use of any of the entities, including rename and access. No_Abort_Statements now checks for any use of Abort_Task, including renaming. The following test programs are compiled using -gnatc -gnatj55. 1. pragma Restrictions (No_Dynamic_Attachment); 2. with Ada.Interrupts; use Ada.Interrupts; 3. procedure NoDynAt is 4.X : Interrupt_ID := Interrupt_ID'First; 5.function XXX 6. (Interrupt : Interrupt_Id) return Boolean 7. renames Is_Attached; | >>> violation of restriction "NO_DYNAMIC_ATTACHMENT" at line 1 8.type M is access function 9. (Interrupt : Interrupt_Id) return Boolean; 10.MV : M := Is_Attached'Access; | >>> violation of restriction "NO_DYNAMIC_ATTACHMENT" at line 1 11. begin 12.if Ada.Interrupts.Is_Reserved (X) then | >>> violation of restriction "NO_DYNAMIC_ATTACHMENT" at line 1 13. null; 14.elsif Ada.Interrupts.Is_Attached (X) then | >>> violation of restriction "NO_DYNAMIC_ATTACHMENT" at line 1 15. null; 16.elsif XXX (X) then 17. null; 18.end if; 19. end NoDynAt; 1. pragma Restrictions (No_Abort_Statements); 2. with Ada.Task_Identification; 3. use Ada.Task_Identification; 4. procedure ATI_Abort is 5.procedure XXX (T : Task_Id) renames Abort_Task; | >>> violation of restriction "NO_ABORT_STATEMENTS" at line 1 6.procedure YYY (T : Task_Id); 7.procedure YYY (T : Task_Id) renames Abort_Task; | >>> violation of restriction "NO_ABORT_STATEMENTS" at line 1 8.type R is access procedure (T : Task_Id); 9.RV : R := Abort_Task'Access; | >>> violation of restriction "NO_ABORT_STATEMENTS" at line 1 10. begin 11.Abort_Task (Current_Task); | >>> violation of restriction "NO_ABORT_STATEMENTS" at line 1 12. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-25 Robert Dewar * rtsfind.adb (Is_RTE): Protect against entity with no scope field (previously this call blew up on the Standard entity). * sem_attr.adb (Analyze_Attribute, case Access): Remove test for No_Abort_Statements, this is now handled in Set_Entity_With_Checks. * exp_ch6.adb, sem_ch10.adb, sem_ch4.adb, sem_ch8.adb, sem_res.adb: Change name Set_Entity_With_Style_Check => Set_Entity_With_Checks. * sem_util.ads, sem_util.adb: Change name Set_Entity_With_Style_Check => Set_Entity_With_Checks. (Set_Entity_With_Checks): Add checks for No_Dynamic_Attachment, Add checks for No_Abort_Statements. Index: sem_ch10.adb === --- sem_ch10.adb(revision 208134) +++ sem_ch10.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -2632,7 +2632,7 @@ -- to consider the unit as unreferenced if this is the only reference -- that occurs. - Set_Entity_With_Style_Check (Name (N), E_Name); + Set_Entity_With_Checks (Name (N), E_Name); Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False); -- Generate references and check No_Dependence restriction for parents @@ -2657,7 +2657,7 @@ exit; end if; -Set_Entity_With_Style_Check (Pref, Par_Name); +Set_Entity_With_Checks (Pref, Par_Name); Generate_Reference (Par_Name, Pref); Check_Restriction_No_Dependence (Pref, N); @@ -2697,7 +2697,7 @@ -- Guard against missing or misspelled child units if Present (Par_Name) then -Set_Entity_With_Style_Check (Pref, Par_Name); +Set_Entity_With_Checks (Pref, Par_Name); Generate_Reference (Par_Name, Pref); else Index: rtsfind.adb === --- rtsfind.adb
[Ada] Implement new pragma Warning_As_Error
This implements a new pragma Warning_As_Error which can be used to
specify that selected warnings are to be treated as errors. See
new documentation in GNAT RM for full details.
The pragma can appear either in a global configuration pragma file
(e.g. gnat.adc), or at the start of a file. Given a global
configuration pragma file containing:
pragma Warning_As_Error ("[-gnatwj]");
which will treat all obsolescent feature warnings as errors, the
following program compiles as shown (compile options here are
@option{-gnatwa.e -gnatld7 -gnatj60}).
1. pragma Warning_As_Error ("*never assigned*");
2. function Warnerr return String is
3.X : Integer;
|
>>> warning(error): variable "X" is never read and
never assigned [-gnatwv]
4.Y : Integer;
|
>>> warning: variable "Y" is assigned but never
read [-gnatwu]
5.
6. begin
7.Y := 0;
8.return %ABC%;
|
>>> warning(error): use of "%" is an obsolescent
feature (RM J.2(4)), use """ instead [-gnatwj]
9. end;
9 lines: No errors, 3 warnings (2 treated as errors)
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-25 Robert Dewar
* atree.ads (Warnings_Treated_As_Errors): New variable.
* errout.adb (Error_Msg_Internal): Set Warn_Err flag in
error object (Initialize): Initialize Warnings_As_Errors_Count
(Write_Error_Summary): Include count of warnings treated as errors.
* erroutc.adb (Warning_Treated_As_Error): New function.
(Matches): Function moved to outer level of package.
* erroutc.ads (Error_Msg_Object): Add Warn_Err flag.
(Warning_Treated_As_Error): New function.
* gnat_rm.texi: Document pragma Treat_Warning_As_Error.
* opt.adb: Add handling of Warnings_As_Errors_Count[_Config].
* opt.ads (Config_Switches_Type): Add entry for
Warnings_As_Errors_Count.
(Warnings_As_Errors_Count): New variable.
(Warnings_As_Errors): New array.
* par-prag.adb: Add dummy entry for Warning_As_Error.
* sem_prag.adb (Analyze_Pragma): Implement new pragma
Warning_As_Error.
* snames.ads-tmpl: Add entries for Warning_As_Error pragma.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 208144)
+++ gnat_rm.texi(working copy)
@@ -275,6 +275,7 @@
* Pragma Use_VADS_Size::
* Pragma Validity_Checks::
* Pragma Volatile::
+* Pragma Warning_As_Error::
* Pragma Warnings::
* Pragma Weak_External::
* Pragma Wide_Character_Encoding::
@@ -1109,6 +1110,7 @@
* Pragma Use_VADS_Size::
* Pragma Validity_Checks::
* Pragma Volatile::
+* Pragma Warning_As_Error::
* Pragma Warnings::
* Pragma Weak_External::
* Pragma Wide_Character_Encoding::
@@ -7557,6 +7559,80 @@
implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
+@node Pragma Warning_As_Error
+@unnumberedsec Pragma Warning_As_Error
+@findex Warning_As_Error
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Warning_As_Error (static_string_EXPRESSION);
+@end smallexample
+
+@noindent
+This configuration pragma allows the programmer to specify a set
+of warnings that will be treated as errors. Any warning which
+matches the pattern given by the pragma argument will be treated
+as an error. This gives much more precise control that -gnatwe
+which treats all warnings as errors.
+
+The pattern may contain asterisks, which match zero or more characters in
+the message. For example, you can use
+@code{pragma Warnings (Off, "*bits of*unused")} to suppress the warning
+message @code{warning: 960 bits of "a" unused}. No other regular
+expression notations are permitted. All characters other than asterisk in
+these three specific cases are treated as literal characters in the match.
+The match is case insensitive, for example XYZ matches xyz.
+
+Another possibility for the static_string_EXPRESSION which works if
+error tags are enabled (@option{-gnatw.e}) is to use the tag string
+preceded by a space,
+as shown in the example below.
+
+The pragma can appear either in a global configuration pragma file
+(e.g. @file{gnat.adc}), or at the start of a file. Given a global
+configuration pragma file containing:
+
+@smallexample @c ada
+pragma Warning_As_Error (" [-gnatwj]");
+@end smallexample
+
+@noindent
+which will treat all obsolescent feature warnings as errors, the
+following program compiles as shown (compile options here are
+@option{-gnatwa.e -gnatld7 -gnatj60}).
+
+@smallexample @c ada
+ 1. pragma Warning_As_Error ("*never assigned*");
+ 2. function Warnerr return String is
+ 3.X : Integer;
+ |
+>>> warning(error): variable "X" is never read and
+never assigned [-gnatwv]
+
+ 4.Y : Integer;
+ |
+>>> warning: variable "Y" is assigned but never
+
[Ada] Handling of SPARK aspects/pragmas on subprogram body stubs
This patch reimplements the support for SPARK aspects/pragmas that apply to a
subprogram body stub and implements a missing rule which forbids the placement
of refinement annotations in subunits.
-- Source --
-- error.ads
package Error
with SPARK_Mode => On,
Abstract_State => State
is
procedure Spec_Stub_Body_1
with Global => (In_Out => State);
procedure Spec_Stub_Body_2
with Global => (In_Out => State),
Depends => (State => State);
procedure Spec_Stub_Body_3
with Global => (In_Out => State),
Depends => (State => State);
procedure Spec_Stub_Body_4
with Global => (In_Out => State),
Depends => (State => State);
procedure Spec_Stub_Body_5
with Global => (In_Out => State),
Depends => (State => State);
end Error;
-- error.adb
package body Error
with SPARK_Mode=> On,
Refined_State => (State => (A, B))
is
A : Integer := 1;
B : Integer := 2;
procedure Spec_Stub_Body_1 is separate
with Depends => (A => B); -- error
-- Depends must appear on the spec (first declaration)
procedure Spec_Stub_Body_2 is separate
with Refined_Global => (In_Out => (A, B));
-- Refined_Depends must appear on the stub (second declaration)
procedure Spec_Stub_Body_3 is separate;
-- Refined_Global and Refined_Depends must appear on the stub (second
-- declaration).
procedure Spec_Stub_Body_4 is separate
with Refined_Global => (In_Out => (A, "error")),
Refined_Depends => ("error" => B);
-- Refined_Global and Refined_Depends are placed properly, but malformed
procedure Spec_Stub_Body_5 is separate
with Refined_Global => (In_Out => (A, "error")),
Refined_Depends => ("error" => B);
-- Refined_Global and Refined_Depends are placed properly, but malformed. A
-- proper body is also missing.
procedure Stub_Body is separate
with Global => (In_Out => (A, B)),
Depends => (A => B);
-- Refined_Global and Refined_Depends apply to a body whose spec (the
-- stub) is not visible.
end Error;
-- error-spec_stub_body_1.adb
separate (Error)
procedure Spec_Stub_Body_1 is begin null; end Spec_Stub_Body_1;
-- error-spec_stub_body_2.adb
separate (Error)
procedure Spec_Stub_Body_2
with Refined_Depends => (A => B) -- error
is begin null; end Spec_Stub_Body_2;
-- error-spec_stub_body_3.adb
separate (Error)
procedure Spec_Stub_Body_3
with Refined_Global => (In_Out => (A, B)), -- error
Refined_Depends => (A => B) -- error
is begin null; end Spec_Stub_Body_3;
-- error-spec_stub_body_4.adb
separate (Error)
procedure Spec_Stub_Body_4 is begin null; end Spec_Stub_Body_4;
-- Compilation and output --
$ gcc -c error.adb
error.adb:9:11: aspect specification must appear in subprogram declaration
error.adb:25:04: warning: subunit "Error.Spec_Stub_Body_5" in file
"error-spec_stub_body_5.adb" not found
error-spec_stub_body_2.adb:4:08: aspect "Refined_Depends" cannot apply to a
subunit
error-spec_stub_body_3.adb:4:08: aspect "Refined_Global" cannot apply to a
subunit
error-spec_stub_body_3.adb:5:08: aspect "Refined_Depends" cannot apply to a
subunit
error-stub_body.adb:4:08: aspect "Refined_Global" cannot apply to a subunit
error-stub_body.adb:5:08: aspect "Refined_Depends" cannot apply to a subunit
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-25 Hristian Kirtchev
* exp_ch6.adb (Add_Or_Save_Precondition): New routine.
(Collect_Body_Postconditions_In_Decls): New routine.
(Collect_Body_Postconditions_Of_Kind): Factor out code. Handle
postcondition aspects or pragmas that appear on a subprogram
body stub.
(Collect_Spec_Preconditions): Factor out code. Handle
precondition aspects or pragmas that appear on a subprogram
body stub.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): The analysis of
aspects that apply to a subprogram body stub is no longer delayed,
the aspects are analyzed on the spot.
(SPARK_Aspect_Error):
Aspects that apply to a subprogram declaration cannot appear in
a subunit.
* sem_ch10.adb Remove with and use clause for Sem_Ch13.
(Analyze_Proper_Body): Add local variable Comp_Unit. Unum
is now a local variable. Code cleanup. Analysis related to
the aspects of a subprogram body stub is now carried out by
Analyze_Subprogram_Body_Helper. Do not propagate the aspects
and/or pragmas of a subprogram body stub to the proper body
as this is no longer needed. Do not analyze the aspects of a
subprogram stub when the corresponding source unit is missing.
(Analyze_Protected_Body_Stub): Flag the illegal use of aspects
on a stub.
(Analyze_Task_Body_Stub): Flag the illegal use of
a
[Ada] Memory leak with Ada 2012 iterator loop
This patch plugs several memory leaks involving Ada 2012 iterator loops by properly managing the secondary stack at each iteration of the loop. -- Source -- -- iterator_leak.adb with Ada.Containers; use Ada.Containers; with Ada.Containers.Vectors; with Ada.Text_IO;use Ada.Text_IO; procedure Iterator_Leak is type Rec is record Comp : Integer := 0; end record; package Vecs is new Vectors (Element_Type => Rec, Index_Type => Positive); V1_Size : constant Integer := 1_000; V2_Size : constant Integer := 1_000; Total : Integer := 1; V1 : Vecs.Vector; V2 : Vecs.Vector; begin Vecs.Set_Length (V1, Count_Type (V1_Size)); Vecs.Set_length (V2, Count_Type (V2_Size)); for Elem1 of V1 loop for Elem2 of V2 loop if Elem1 = Elem2 then Total := Total + 1; end if; end loop; end loop; for Index1 in 1 .. V1_Size loop for Index2 in 1 .. V2_Size loop declare Elem1 : constant Rec := V1 (Index1); Elem2 : constant Rec := V2 (Index2); begin if Elem1 = Elem2 then Total := Total + 1; end if; end; end loop; end loop; for Cur1 in Vecs.Iterate (V1) loop for Cur2 in Vecs.Iterate (V2) loop if V1 (Cur1) = V2 (Cur2) then Total := Total + 1; end if; end loop; end loop; end Iterator_Leak; -- Compilation and output -- $ gnatmake -q iterator_leak.adb -largs -lgmem $ ./iterator_leak $ gnatmem iterator_leak > output.txt $ grep "Total number" output.txt Total number of allocations: 2 Total number of deallocations : 2 Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-25 Hristian Kirtchev * einfo.ads Update the usage of flag Uses_Sec_Stack. Uses_Sec_Stack now applies to E_Loop entities. * exp_ch5.adb (Expand_Iterator_Loop): The temporary for a cursor now starts with the letter 'C'. This makes reading expanded code easier. * exp_ch7.adb (Establish_Transient_Scope): Add local variable Iter_Loop. Signal that an Ada 2012 iterator loop requires secondary stack management when creating a transient scope for an element reference. * exp_util.adb (Process_Statements_For_Controlled_Objects): When wrapping the statements of a loop, pass the E_Loop entity to the wrapping machinery. (Wrap_Statements_In_Block): Add formal parameter Scop along with comment on usage. Add local variables Block_Id, Block_Nod and Iter_Loop. Mark the generated block as requiring secondary stack management when the block is created inside an Ada 2012 iterator loop. This ensures that any reference objects are reclaimed on each iteration of the loop. * sem_ch5.adb (Analyze_Loop_Statement): Mark the generated block tasked with the handling of container iterators as requiring secondary stack management. This ensures that iterators are reclaimed when the loop terminates or is exited in any fashion. * sem_util.adb (Add_Block_Identifier): New routine. (Find_Enclosing_Iterator_Loop): New routine. * sem_util.ads (Add_Block_Identifier): New routine. (Find_Enclosing_Iterator_Loop): New routine. Index: exp_ch5.adb === --- exp_ch5.adb (revision 208132) +++ exp_ch5.adb (revision 208133) @@ -3264,7 +3264,7 @@ Ent : Entity_Id; begin - Cursor := Make_Temporary (Loc, 'I'); + Cursor := Make_Temporary (Loc, 'C'); -- For an container element iterator, the iterator type -- is obtained from the corresponding aspect, whose return Index: exp_ch7.adb === --- exp_ch7.adb (revision 208132) +++ exp_ch7.adb (revision 208133) @@ -3558,6 +3558,7 @@ procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is Loc : constant Source_Ptr := Sloc (N); + Iter_Loop : Entity_Id; Wrap_Node : Node_Id; begin @@ -3571,8 +3572,8 @@ return; - -- If we have encountered Standard there are no enclosing - -- transient scopes. + -- If we have encountered Standard there are no enclosing transient + -- scopes. elsif Scope_Stack.Table (S).Entity = Standard_Standard then exit; @@ -3581,17 +3582,17 @@ Wrap_Node := Find_Node_To_Be_Wrapped (N); - -- Case of no wrap node, false alert, no transient scope needed + -- The context does not contain a node that requires a transient scope, + -- nothing to do. if No (Wrap_Node) then null; - -- If the node to
[Ada] Illegal use of SPARK volatile object not detected
This patch simplifies the entity resolution machinery which detects an illegaly used SPARK volatile object with enabled external properties Async_Writers or Effective_Reads. The mechanism no longer traverses the parent chain as this is not needed. -- Source -- -- volatile_use.ads package Volatile_Use with SPARK_Mode => On is V1 : Integer with Volatile, Async_Writers => True; procedure Test_Eval_Order_OK (X : out Boolean) with Global => (Input => V1), Depends => (X => V1); procedure Test_Eval_Order_Bad1 (X : out Boolean) with Global => (Input => V1), Depends => (X => V1); procedure Test_Eval_Order_Bad2 (X : out Boolean) with Global => (Input => V1), Depends => (X => V1); end Volatile_Use; -- volatile_use.adb package body Volatile_Use with SPARK_Mode => On is procedure Test_Eval_Order_OK (X : out Boolean) is T1 : Integer; T2 : Integer; begin T1 := V1; T2 := V1; X := (T1 <= T2); end Test_Eval_Order_OK; procedure Test_Eval_Order_Bad1 (X : out Boolean) is T1 : Integer; begin T1 := V1; X := (T1 <= V1); end Test_Eval_Order_Bad1; procedure Test_Eval_Order_Bad2 (X : out Boolean) is begin X := (V1 <= V1); end Test_Eval_Order_Bad2; end Volatile_Use; -- Compilation and output -- $ gcc -c volatile_use.adb volatile_use.adb:15:19: volatile object cannot appear in this context (SPARK RM 7.1.3(13)) volatile_use.adb:20:13: volatile object cannot appear in this context (SPARK RM 7.1.3(13)) volatile_use.adb:20:19: volatile object cannot appear in this context (SPARK RM 7.1.3(13)) Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-25 Hristian Kirtchev * sem_res.adb (Appears_In_Check): New routine. (Resolve_Entity_Name): Remove local variables Prev and Usage_OK. Par is now a constant. Remove the parent chain traversal as the placement of a volatile object with enabled property Async_Writers and/or Effective_Reads must appear immediately within a legal construct. Index: sem_res.adb === --- sem_res.adb (revision 208076) +++ sem_res.adb (working copy) @@ -6434,13 +6434,43 @@ -- Used to resolve identifiers and expanded names procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is - E: constant Entity_Id := Entity (N); - Par : Node_Id; - Prev : Node_Id; + function Appears_In_Check (Nod : Node_Id) return Boolean; + -- Denote whether an arbitrary node Nod appears in a check node - Usage_OK : Boolean := False; - -- Flag set when the use of a volatile object agrees with its context + -- + -- Appears_In_Check -- + -- + function Appears_In_Check (Nod : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a check node + + Par := Nod; + while Present (Par) loop +if Nkind (Par) in N_Raise_xxx_Error then + return True; + +-- Prevent the search from going too far + +elsif Is_Body_Or_Package_Declaration (Par) then + exit; +end if; + +Par := Parent (Par); + end loop; + + return False; + end Appears_In_Check; + + -- Local variables + + E : constant Entity_Id := Entity (N); + Par : constant Node_Id := Parent (N); + + -- Start of processing for Resolve_Entity_Name + begin -- If garbage from errors, set to Any_Type and return @@ -6555,62 +6585,43 @@ (Async_Writers_Enabled (E) or else Effective_Reads_Enabled (E)) then - Par := Parent (N); - Prev := N; - while Present (Par) loop + -- The volatile object can appear on either side of an assignment --- The volatile object can appear on either side of an assignment + if Nkind (Par) = N_Assignment_Statement then +null; -if Nkind (Par) = N_Assignment_Statement then - Usage_OK := True; - exit; + -- The volatile object is part of the initialization expression of + -- another object. Ensure that the climb of the parent chain came + -- from the expression side and not from the name side. --- The volatile object is part of the initialization expression of --- another object. Ensure that the climb of the parent chain came --- from the expression side and not from the name side. + elsif Nkind (Par) = N_Object_Declaration + and then Present (Expression (Par)) + and then N = Expression (Par) + then +null; -elsif Nkind (Par) = N_
[Ada] Syntax checks when SPARK_Mode is Off
This patch adds syntax checks for SPARK aspects/pragmas Abstract_State,
Depends, Global, Initializes, Part_Of, Refined_Global, Refined_Depends and
Refined_State that trigger when SPARK features are disabled through SPARK_Mode
=> Off. The patch also suppresses refinement-related checks when the associated
context is a package or subprogram body.
-- Source --
-- issue_when_off.ads
package Issue_When_Off
with SPARK_Mode => Off,
Abstract_State => "junk state", -- error
Initializes=> 1+2, -- error
Initial_Condition => 3.4 -- error
is
procedure Error
with Global => (OK_Mode => "global item"), -- error
Depends => ("output" => 56); -- error
end Issue_When_Off;
-- issue_when_off.adb
package body Issue_When_Off
with SPARK_Mode=> Off,
Refined_State => ("state" => (123, "constituent")) -- error
is
procedure Error
with Refined_Global => (OK_Mode => "global item"), -- error
Refined_Depends => ("output" => (4.5, "input")) -- error
is begin null; end Error;
end Issue_When_Off;
-- suppress_when_off.ads
package Suppress_When_Off
with SPARK_Mode=> Off,
Abstract_State=> State
is
Var : Integer := 0;
function OK_1 (Formal : Integer) return Integer
with Global => (Input => (State, Var)),
Depends => (OK_1'Result => (State, Var));
procedure OK_2;
end Suppress_When_Off;
-- suppress_when_off.adb
package body Suppress_When_Off -- suppressed error
with SPARK_Mode => Off
is
function OK_1 (Formal : Integer) return Integer is -- suppress error
begin
return -1;
end OK_1;
procedure OK_2
with Refined_Global => null,-- suppressed error
Refined_Depends => null -- suppressed error
is begin null; end OK_2;
end Suppress_When_Off;
-- Compilation and output --
$ gcc -c issue_when_off.adb
$ gcc -c suppress_when_off.adb
issue_when_off.adb:3:26: malformed item
issue_when_off.adb:3:38: malformed item
issue_when_off.adb:3:43: malformed item
issue_when_off.adb:6:43: malformed global list
issue_when_off.adb:7:31: malformed item
issue_when_off.adb:7:44: malformed item
issue_when_off.adb:7:49: malformed item
issue_when_off.ads:3:26: malformed abstract state declaration
issue_when_off.ads:4:27: malformed item
issue_when_off.ads:5:29: expected type "Standard.Boolean"
issue_when_off.ads:5:29: found type universal real
issue_when_off.ads:8:35: malformed global list
issue_when_off.ads:9:23: malformed item
issue_when_off.ads:9:35: malformed input dependency list
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-24 Hristian Kirtchev
* sem_ch6.adb (Analyze_Subprogram_Body_Contract): Do not enforce
global and dependence refinement when SPARK_Mode is off.
* sem_ch7.adb (Analyze_Package_Body_Contract): Do not enforce
state refinement when SPARK_Mode is off.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add local
variable Decl. Insert the generated pragma for Refined_State
after a potential pragma SPARK_Mode.
* sem_prag.adb (Analyze_Depends_In_Decl_Part): Add local
constant Deps. Remove local variable Expr. Check the syntax
of pragma Depends when SPARK_Mode is off. Factor out the
processing for extra parenthesis around individual clauses.
(Analyze_Global_In_Decl_List): Items is now a constant. Check
the syntax of pragma Global when SPARK_Mode is off.
(Analyze_Initializes_In_Decl_Part): Check the syntax of pragma
Initializes when SPARK_Mode is off.
(Analyze_Part_Of): Check
the syntax of the encapsulating state when SPARK_Mode is off.
(Analyze_Pragma): Check the syntax of pragma Abstract_State when
SPARK_Mode is off. Move the declaration order check with respect
to pragma Initializes to the end of the processing. Do not verify
the declaration order for pragma Initial_Condition when SPARK_Mode
is off. Do not complain about a useless package refinement when
SPARK_Mode is off.
(Analyze_Refined_Depends_In_Decl_Part): Refs
is now a constant. Check the syntax of pragma Refined_Depends
when SPARK_Mode is off.
(Analyze_Refined_Global_In_Decl_Part):
Check the syntax of pragma Refined_Global when SPARK_Mode is off.
(Analyze_Refined_State_In_Decl_Part): Check the syntax of pragma
Refined_State when SPARK_Mode is off.
(Check_Dependence_List_Syntax): New routine.
(Check_Global_List_Syntax): New routine.
(Check_Initialization_List_Syntax): New routine.
(Check_Item_Syntax): New routine.
(Check_State_Declaration_Syntax): New routine.
(Check_Refinement_List_Syntax): New routine.
(Has_Extra_Parentheses)
[Ada] Improve error handling in Ada.Directories search system
This change ensures that when iterating on directory entries using Ada.Directories, and some parent of the searched directory is not accessable, Use_Error is appropriately raised (instead of just yielding no entries). The following program must raise USE_ERROR when run in a directory whose parent is not accessable by the running user: with Ada.Directories; use Ada.Directories; with Ada.Text_IO; use Ada.Text_IO; procedure LSD is S : Search_Type; E : Directory_Entry_Type; begin Start_Search (S, ".", "*"); while More_Entries (S) loop Get_Next_Entry (S, E); Put_Line (Kind (E)'Img & ": " & Simple_Name (E)); end loop; end LSD; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-24 Thomas Quinot * adaint.h (struct file_attributes): New component "error" (__gnat_error_attributes): Accessor for the above. * adaint.c (__gnat_error_attributes): New subprogram (__gnat_stat): Fix returned value (expect errno value) (__gnat_stat_to_attr): Add management of error component (set to stat errno value, except for missing files where it is set to 0, and exists is set to 0). * osint.ads (File_Attributes_Size): Update per change above, also clarify documentation. * s-filatt.ads: New file, binding to file attributes related functions. * Makefile.rtl (s-filatt): New runtime unit. * s-crtl.ads (strlen): Expose binding to GCC builtin (falls back to library function if not available on target). * s-os_lib.ads, s-os_lib.adb (Errno_Message): New subprogram. * s-oscons-tmplt.c (SIZEOF_struct_file_attributes, SIZEOF_struct_dirent_alloc): New constants. * Make-generated.in (s-oscons.ads): Now requires adaint.h. * a-direct.adb (Fetch_Next_Entry): Fix incorrect buffer sizes. Perform appropriate error checking if stat fails (do not just ignore existing files if stat fails) * gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Update dependencies. Index: a-direct.adb === --- a-direct.adb(revision 208067) +++ a-direct.adb(working copy) @@ -6,7 +6,7 @@ @@ -36,21 +36,18 @@ with Ada.Strings.Fixed; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; -with System; use System; -with System.CRTL; use System.CRTL; -with System.File_IO; use System.File_IO; -with System.OS_Constants; use System.OS_Constants; -with System.OS_Lib; use System.OS_Lib; -with System.Regexp; use System.Regexp; +with System; use System; +with System.CRTL;use System.CRTL; +with System.File_Attributes; use System.File_Attributes; +with System.File_IO; use System.File_IO; +with System.OS_Constants;use System.OS_Constants; +with System.OS_Lib; use System.OS_Lib; +with System.Regexp; use System.Regexp; package body Ada.Directories is - Filename_Max : constant Integer := 1024; - -- 1024 is the value of FILENAME_MAX in stdio.h - type Dir_Type_Value is new Address; -- This is the low-level address directory structure as returned by the C -- opendir routine. @@ -708,7 +705,7 @@ -- procedure Fetch_Next_Entry (Search : Search_Type) is - Name : String (1 .. 255); + Name : String (1 .. NAME_MAX); Last : Natural; Kind : File_Kind := Ordinary_File; @@ -717,9 +714,7 @@ Filename_Addr : Address; Filename_Len : aliased Integer; - Buffer : array (0 .. Filename_Max + 12) of Character; - -- 12 is the size of the dirent structure (see dirent.h), without the - -- field for the filename. + Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character; function readdir_gnat (Directory : Address; @@ -744,43 +739,60 @@ exit; end if; + if Filename_Len > Name'Length then +raise Use_Error with "file name too long"; + end if; + declare -subtype Path_String is String (1 .. Filename_Len); -typePath_String_Access is access Path_String; +subtype Name_String is String (1 .. Filename_Len); +Dent_Name : Name_String; +for Dent_Name'Address use Filename_Addr; +pragma Import (Ada, Dent_Name); -function Address_To_Access is new - Ada.Unchecked_Conversion -(Source => Address, - Target => Path_String_Access); - -Path_Access : constant Path_String_Access := - Address_To_Access (Filename_Addr); - begin Last := Filename_Len; -Name (1 .. Last) := Path_Access.all; +Name (1 .. Last) := Dent_Name
[Ada] Add missing Ravenscar restrictions
This patch enforces the restrictions No_Local_Timing_Events and No_Specific_Termination_Handlers when the Ravenscar restrictions are in effect, as required by D.13(6/3). The following tests must trigger the following errors: $ gcc -c tev.adb tev.adb:6:04: violation of restriction "NO_LOCAL_TIMING_EVENTS" tev.adb:6:04: from profile "RAVENSCAR" at line 1 $ gcc -c sth.adb sth.adb:13:24: violation of restriction "NO_SPECIFIC_TERMINATION_HANDLERS" sth.adb:13:24: from profile "RAVENSCAR" at line 1 sth.adb:16:30: violation of restriction "NO_SPECIFIC_TERMINATION_HANDLERS" sth.adb:16:30: from profile "RAVENSCAR" at line 1 pragma Profile (Ravenscar); with Ada.Real_Time.Timing_Events; procedure TEV is E : Ada.Real_Time.Timing_Events.Timing_Event; begin null; end TEV; pragma Profile (Ravenscar); with Ada.Task_Termination; with Ada.Task_Identification; with Tasking; procedure STH is TH : Ada.Task_Termination.Termination_Handler; Self : constant Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task; begin Ada.Task_Termination.Set_Specific_Handler (Self, Tasking.Termination_Controller.Handler'Access); TH := Ada.Task_Termination.Specific_Handler (Self); end STH; with Ada.Exceptions; with Ada.Task_Identification; with Ada.Task_Termination; package Tasking is protected Termination_Controller is procedure Handler (Cause : Ada.Task_Termination.Cause_Of_Termination; T : Ada.Task_Identification.Task_Id; X : Ada.Exceptions.Exception_Occurrence); end Termination_Controller; end Tasking; package body Tasking is protected body Termination_Controller is procedure Handler (Cause : Ada.Task_Termination.Cause_Of_Termination; T : Ada.Task_Identification.Task_Id; X : Ada.Exceptions.Exception_Occurrence) is begin null; end Handler; end Termination_Controller; end Tasking; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-24 Jose Ruiz * s-rident.ads (Profile_Info): For Ravenscar, the restrictions No_Local_Timing_Events and No_Specific_Termination_Handlers must be set, according to the Ravenscar profile definition in D.13(6/3). Index: s-rident.ads === --- s-rident.ads(revision 208067) +++ s-rident.ads(working copy) @@ -476,13 +476,15 @@ -- plus these additional restrictions: - No_Calendar => True, - No_Implicit_Heap_Allocations=> True, - No_Relative_Delay => True, - No_Select_Statements=> True, - No_Task_Termination => True, - Simple_Barriers => True, - others => False), + No_Calendar => True, + No_Implicit_Heap_Allocations => True, + No_Local_Timing_Events => True, + No_Relative_Delay=> True, + No_Select_Statements => True, + No_Specific_Termination_Handlers => True, + No_Task_Termination => True, + Simple_Barriers => True, + others => False), -- Value settings for Ravenscar (same as Restricted)
[Ada] Enabled external properties and volatile objects
This patch corrects the predicate which determines whether an object has an
enabled external property to account for implicitly enabled properties.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-24 Hristian Kirtchev
* sem_prag.adb (Analyze_Global_Item): Move the check concerning
the use of volatile objects as global items in a function to
the variable related checks section.
* sem_util.adb (Async_Readers_Enabled): Directly call
Has_Enabled_Property.
(Async_Writers_Enabled): Directly call Has_Enabled_Property.
(Effective_Reads_Enabled): Directly call Has_Enabled_Property.
(Effective_Writes_Enabled): Directly call Has_Enabled_Property.
(Has_Enabled_Property): Rename formal parameter State_Id to Item_Id.
Update the comment on usage. State_Has_Enabled_Property how handles
the original logic of the routine. Add processing for variables.
(State_Has_Enabled_Property): New routine.
(Variable_Has_Enabled_Property): New routine.
Index: sem_prag.adb
===
--- sem_prag.adb(revision 208076)
+++ sem_prag.adb(working copy)
@@ -2060,16 +2060,28 @@
-- Variable related checks
- else
+ elsif Is_SPARK_Volatile_Object (Item_Id) then
+
+ -- A volatile object cannot appear as a global item of a
+ -- function. This check is only relevant when SPARK_Mode is
+ -- on as it is not a standard Ada legality rule.
+
+ if SPARK_Mode = On
+and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
+ then
+ Error_Msg_NE
+ ("volatile object & cannot act as global item of a "
+& "function (SPARK RM 7.1.3(9))", Item, Item_Id);
+ return;
+
-- A volatile object with property Effective_Reads set to
-- True must have mode Output or In_Out.
- if Is_SPARK_Volatile_Object (Item_Id)
-and then Effective_Reads_Enabled (Item_Id)
+ elsif Effective_Reads_Enabled (Item_Id)
and then Global_Mode = Name_Input
then
Error_Msg_NE
- ("volatile item & with property Effective_Reads must "
+ ("volatile object & with property Effective_Reads must "
& "have mode In_Out or Output (SPARK RM 7.1.3(11))",
Item, Item_Id);
return;
@@ -2100,19 +2112,6 @@
Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
end if;
--- A volatile object cannot appear as a global item of a function.
--- This check is only relevant when SPARK_Mode is on as it is not
--- a standard Ada legality rule.
-
-if SPARK_Mode = On
- and then Is_SPARK_Volatile_Object (Item)
- and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
-then
- Error_Msg_NE
- ("volatile object & cannot act as global item of a function "
- & "(SPARK RM 7.1.3(9))", Item, Item_Id);
-end if;
-
-- The same entity might be referenced through various way. Check
-- the entity of the item rather than the item itself.
Index: sem_util.adb
===
--- sem_util.adb(revision 208067)
+++ sem_util.adb(working copy)
@@ -116,11 +116,11 @@
-- have a default.
function Has_Enabled_Property
- (State_Id : Node_Id;
+ (Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
-- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
- -- Determine whether an abstract state denoted by its entity State_Id has
- -- enabled property Property.
+ -- Determine whether an abstract state or a variable denoted by entity
+ -- Item_Id has enabled property Property.
function Has_Null_Extension (T : Entity_Id) return Boolean;
-- T is a derived tagged type. Check whether the type extension is null.
@@ -575,12 +575,7 @@
function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
begin
- if Ekind (Id) = E_Abstract_State then
- return Has_Enabled_Property (Id, Name_Async_Readers);
-
- else pragma Assert (Ekind (Id) = E_Variable);
- return Present (Get_Pragma (Id, Pragma_Async_Readers));
- end if;
+ return Has_Enabled_Property (Id, Name_Async_Readers);
end Async_Readers_Enabled;
---
@@ -589,12 +584,7 @@
function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
begin
- if Ekind (Id) = E_Abstract_State the
[Ada] Handling of generalized indexing in ASIS
This patch introduces a new semantic attribute Generalized_Indexing, for indexed_components that are instances of Ada 2012 container indexing operations. Analysis and resolution of such nodes is performed on the attribute, and the original source is preserved for ASIS operations. If expansion is enabled, the indexed component is replaced by the value of this attribute, which is in a call to an Indexing aspect, in most case wrapped in a dereference operation. Otherwise the original node is type-annotated, which makes ASIS queries and pretty-printing simpler. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-24 Ed Schonberg * sinfo.ads, sinfo.adb: New attribute Generalized_Indexing, for indexed_components that are instances of Ada 2012 container indexing operations. Analysis and resolution of such nodes is performed on the attribute, and the original source is preserved for ASIS operations. If expansion is enabled, the indexed component is replaced by the value of this attribute, which is in a call to an Indexing aspect, in most case wrapped in a dereference operation. * sem_ch4.adb (Analyze_Indexed_Component): Create Generalized_Indexing attribute when appropriate. (Analyze_Call): If prefix is not overloadable and has an indexing aspect, transform into an indexed component so it can be analyzed as a potential container indexing. (Analyze_Expression): If node is an indexed component with a Generalized_ Indexing, do not re-analyze. * sem_res.adb (Resolve_Generalized_Indexing): Complete resolution of an indexed_component that has been transformed into a container indexing operation. (Resolve_Indexed_Component): Call the above when required. (Resolve): Do not insert an explicit dereference operation on an indexed_component whose type has an implicit dereference: the operation is inserted when resolving the related Generalized_Indexing. Index: sinfo.adb === --- sinfo.adb (revision 208067) +++ sinfo.adb (working copy) @@ -1399,6 +1399,14 @@ return Flag6 (N); end From_Default; + function Generalized_Indexing + (N : Node_Id) return Node_Id is + begin + pragma Assert (False +or else NT (N).Nkind = N_Indexed_Component); + return Node4 (N); + end Generalized_Indexing; + function Generic_Associations (N : Node_Id) return List_Id is begin @@ -4531,6 +4539,14 @@ Set_Flag6 (N, Val); end Set_From_Default; + procedure Set_Generalized_Indexing + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False +or else NT (N).Nkind = N_Indexed_Component); + Set_Node4 (N, Val); + end Set_Generalized_Indexing; + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id) is begin Index: sinfo.ads === --- sinfo.ads (revision 208067) +++ sinfo.ads (working copy) @@ -1277,6 +1277,15 @@ --declaration is treated as an implicit reference to the formal in the --ali file. + -- Generalized_Indexing (Node4-Sem) + -- Generalized_Indexing is set in Indexed_Component nodes that are Ada 2012 + -- container indexing operations. The value of the attribute is a function + -- call (possibly dereferenced) that corresponds to the proper expansion + -- of the source indexing operation. Before expansion, the source node + -- is rewritten as the resolved generalized indexing. In ASIS mode, the + -- expansion does not take place, so that the source is preserved and + -- properly annotated with types. + -- Generic_Parent (Node5-Sem) --Generic_Parent is defined on declaration nodes that are instances. The --value of Generic_Parent is the generic entity from which the instance @@ -3470,6 +3479,7 @@ -- Sloc contains a copy of the Sloc value of the Prefix -- Prefix (Node3) -- Expressions (List1) + -- Generalized_Indexing (Node4-Sem) -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression @@ -8912,6 +8922,8 @@ function From_Default (N : Node_Id) return Boolean;-- Flag6 + function Generalized_Indexing + (N : Node_Id) return Node_Id;-- Node4 function Generic_Associations (N : Node_Id) return List_Id;-- List3 @@ -9908,6 +9920,9 @@ procedure Set_From_Default (N : Node_Id; Val : Boolean := True);-- Flag6 + procedure Set_Generalized_Indexing + (N : Node_Id; Val : Node_Id);-- Node4 + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id);-- List3 @@ -10918,7 +10933,7 @@ (1 => True,-- Expressions (List1) 2 => False, -- unused 3 => True,-- Prefix (Node3) -
[Ada] Do not issue warning specific to compilation in GNATprove mode
In GNATprove mode, a warning on ignored pre/post on imported
subprograms was misleading, as it was meant for compilation only,
while formal verification does take these into account. Hence, we
do not generate this warning in GNATprove mode anymore.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-24 Yannick Moy
* freeze.adb (Freeze_Entity): Do not issue warning
for pre/post being ignored on imported subprogram in GNATprove
mode.
Index: freeze.adb
===
--- freeze.adb (revision 208067)
+++ freeze.adb (working copy)
@@ -3868,9 +3868,12 @@
end if;
end;
- -- Pre/post conditions are implemented through a subprogram in
- -- the corresponding body, and therefore are not checked on an
- -- imported subprogram for which the body is not available.
+ -- Pre/post conditions are implemented through a subprogram
+ -- in the corresponding body, and therefore are not checked on
+ -- an imported subprogram for which the body is not available.
+ -- This warning is not issued in GNATprove mode, as these
+ -- contracts are handled in formal verification, so the
+ -- warning would be misleading in that case.
-- Could consider generating a wrapper to take care of this???
@@ -3878,6 +3881,7 @@
and then Is_Imported (E)
and then Present (Contract (E))
and then Present (Pre_Post_Conditions (Contract (E)))
+ and then not GNATprove_Mode
then
Error_Msg_NE
("pre/post conditions on imported subprogram are not "
[Ada] Do not expand dynamic subtypes for expressions in GNATprove_mode
During expansion, extra subtypes are generated for many expressions. This is in fact not needed and even harmful for the formal verification mode controlled by GNATprove_mode. This subtype expansion is now disabled in GNATprove_mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-24 Johannes Kanig * exp_util.adb (Expand_Subtype_From_Expr): Do not expand subtypes in GNATprove_mode, gnat2why doesn't need nor use these types. Index: exp_util.adb === --- exp_util.adb(revision 208067) +++ exp_util.adb(working copy) @@ -2074,19 +2074,15 @@ -- may be constants that depend on the bounds of a string literal, both -- standard string types and more generally arrays of characters. - -- In GNATprove mode, we also need the more precise subtype to be set + -- In GNATprove mode, these extra subtypes are not needed - if not (Expander_Active or GNATprove_Mode) -and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp))) - then + if GNATprove_Mode then return; end if; - -- In GNATprove mode, Unc_Type might not be complete when analyzing - -- a generic unit. As generic units are not analyzed directly in - -- GNATprove, return here rather than failing later. - - if GNATprove_Mode and then No (Underlying_Type (Unc_Type)) then + if not Expander_Active +and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp))) + then return; end if;
[Ada] gnatmake -s: no recompilation when adding some -gnate? switches
When gnatmake is invoked with -s and some additional compilation switches
(-gnateA, -gnateE, -gnateF, -gnateinn, -gnateu, -gnateV or -gnateY),
recompilation does not necessarily occur. This patch fix this.
The test is to invoke gnatmake with -s and one or these switches:
recompilation should occur.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Vincent Celier
* switch-m.adb (Normalize_Compiler_Switches): Take into account
switches that are recorded in ALI files: -gnateA, -gnateE,
-gnateF, -gnateinn, -gnateu, -gnateV and -gnateY.
Index: switch-m.adb
===
--- switch-m.adb(revision 207879)
+++ switch-m.adb(working copy)
@@ -310,6 +310,10 @@
else
case Switch_Chars (Ptr) is
+ when 'A' =>
+ Ptr := Ptr + 1;
+ Add_Switch_Component ("-gnateA");
+
when 'D' =>
Storing (First_Stored + 1 ..
First_Stored + Max - Ptr + 1) :=
@@ -319,16 +323,17 @@
First_Stored + Max - Ptr + 1));
Ptr := Max + 1;
- when 'G' =>
+ when 'E' | 'F' | 'G' | 'S' | 'u' | 'V' | 'Y' =>
+ Add_Switch_Component
+("-gnate" & Switch_Chars (Ptr));
Ptr := Ptr + 1;
- Add_Switch_Component ("-gnateG");
- when 'I' =>
- Ptr := Ptr + 1;
-
+ when 'i' | 'I' =>
declare
- First : constant Positive := Ptr - 1;
+ First : constant Positive := Ptr;
begin
+ Ptr := Ptr + 1;
+
if Ptr <= Max and then
Switch_Chars (Ptr) = '='
then
@@ -376,10 +381,6 @@
return;
- when 'S' =>
- Ptr := Ptr + 1;
- Add_Switch_Component ("-gnateS");
-
when others =>
Last := 0;
return;
[Ada] Improve error messages on SPARK annotations
This patch updates the error diagnostics of various SPARK features to emit
clearer and more descriptive messages.
-- Source --
-- messages.ads
package Messages
with SPARK_Mode => On
is
A : Integer := 1;
B : Integer := 2;
procedure Error_1 (X : in Integer)
with Depends => (X => +null);
procedure Error_2 (X : out Integer)
with Depends => (X => X);
procedure Error_3 (X : in out Integer)
with Depends => (X => null);
procedure Error_4
with Global => (In_Out => A),
Depends => ((A, B) => null);
end Messages;
-- Compilation and output --
$ gcc -c messages.ads
messages.ads:8:23: read-only parameter "X" cannot appear as output in
dependence relation (SPARK RM 6.1.5(5))
messages.ads:11:28: write-only parameter "X" cannot appear as input in
dependence relation (SPARK RM 6.1.5(6))
messages.ads:13:23: parameter "X" must appear in at least one input dependence
list (SPARK RM 6.1.5(8))
messages.ads:17:33: global "A" must appear in at least one input dependence
list (SPARK RM 6.1.5(8))
messages.ads:18:27: global "B" cannot appear in dependence relation
messages.ads:18:27: "B" is not part of the input or output set of subprogram
"Error_4"
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Hristian Kirtchev
* sem_prag.adb (Add_Item_To_Name_Buffer): New routine.
(Analyze_Contract_Case): Remove the use of
"may". Replace "aspect Contract_Cases" to avoid categorization
of aspect vs pragma.
(Analyze_External_Property_In_Decl_Part): Remove the use of "formal".
(Analyze_Global_Item): Remove
the use of "formal", specify the subprogram. Split the
error message about a state with visible refinement into
two. Remove the use of "global" from "volatile global item".
(Analyze_Initialization_Item): Ensure that the SPARK RM reference
is on one line.
(Analyze_Input_Output): Update the call to
Check_Mode. Specify the duplicated item. Reword the error
message concerning an input of a null output list. Use "\"
for error message continuation.
(Analyze_Part_Of): Remove
the use of "may". Use "\" for error message continuation.
(Analyze_Refined_Depends_In_Decl_Part): Update the error
message concerning a useless refinement to match the format
of Refined_Global.
(Analyze_Refined_Global_In_Decl_Part): Reword the error message
concerning a useless refinement.
(Analyze_Refinement_Clause): Use "\" for error message continuation.
(Check_Constituent_Usage): Use "\" for error message continuation.
(Check_Dependency_Clause): Use "\" for error message continuation.
(Check_Matching_Constituent): Use "\" for error message continuation.
(Check_Missing_Part_Of): Use "\" for error message continuation.
(Check_Mode): Renamed to
Check_Role. Update the comment on usage. Redo the error reporting
to use Role_Error.
(Check_Mode_Restriction_In_Enclosing_Context): Use "\" for error
message continuation.
(Find_Mode): Renamed to Find_Role. Update the parameter profile along
with comment on usage. Update all occurrences of Is_Input and Is_Output.
(Inconsistent_Mode_Error): Use "\" for error message continuation.
(Input_Match): Use "\" for error message continuation.
(Role_Error): New routine.
(Set_Convention_From_Pragma): Use "\" for error message continuation.
(Usage_Error): Add local variable Error_Msg. Build specialized error
message showcasing the offending item kind. Redo the diagnostics for
unconstrained types.
Index: sem_prag.adb
===
--- sem_prag.adb(revision 207948)
+++ sem_prag.adb(working copy)
@@ -399,7 +399,8 @@
if Present (Extra_Guard) then
Error_Msg_N
- ("contract case may have only one case guard", Extra_Guard);
+ ("contract case must have exactly one case guard",
+ Extra_Guard);
end if;
-- Check the placement of "others" (if available)
@@ -407,7 +408,7 @@
if Nkind (Case_Guard) = N_Others_Choice then
if Others_Seen then
Error_Msg_N
-("only one others choice allowed in aspect Contract_Cases "
+("only one others choice allowed in contract cases "
& "(SPARK RM 6.1.3(1))", Case_Guard);
else
Others_Seen := True;
@@ -415,7 +416,7 @@
elsif Others_Seen then
Error_Msg_N
- ("others must be the last choice in aspect Contract_Cases "
+ ("others must be the last choice in contract cases "
[Ada] Allow Object_Size that is a multiple of the alignment
For composite types, any object size should be allowed that is a multiple
of the alignment, but the front end was rejecting some cases. The following
should compile clean, giving the output shown for -gnatR2:
1. package ObjSizeTest is
2.type R is record
3. A : Integer;
4. B : Character;
5.end record;
6.for R'Object_Size use 40;
7.for R'Size use 40;
8.for R'Alignment use 1;
9. end ObjSizeTest;
Representation information for unit Objsizetest (spec)
for R'Size use 40;
for R'Alignment use 1;
for R use record
A at 0 range 0 .. 31;
B at 4 range 0 .. 7;
end record;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Robert Dewar
* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
Object_Size): For non-scalar types allow any value that is a
multiple of 8.
* gnat_rm.texi: Document Object_Size for composites more clearly.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 207947)
+++ gnat_rm.texi(working copy)
@@ -8740,6 +8740,10 @@
integer field, and so the default size of record objects for this type
will be 64 (8 bytes).
+If the alignment of the above record is specified to be 1, then the
+object size will be 40 (5 bytes). This is true by default, and also
+an object size of 40 can be explicitly specified in this case.
+
A consequence of this capability is that different object sizes can be
given to subtypes that would otherwise be considered in Ada to be
statically matching. But it makes no sense to consider such subtypes
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 207948)
+++ sem_ch13.adb(working copy)
@@ -4413,17 +4413,17 @@
else
Check_Size (Expr, U_Ent, Size, Biased);
- if Size /= 8
-and then
- Size /= 16
-and then
- Size /= 32
-and then
- UI_Mod (Size, 64) /= 0
- then
- Error_Msg_N
-("Object_Size must be 8, 16, 32, or multiple of 64",
- Expr);
+ if Is_Scalar_Type (U_Ent) then
+ if Size /= 8 and then Size /= 16 and then Size /= 32
+and then UI_Mod (Size, 64) /= 0
+ then
+ Error_Msg_N
+ ("Object_Size must be 8, 16, 32, or multiple of 64",
+Expr);
+ end if;
+
+ elsif Size mod 8 /= 0 then
+ Error_Msg_N ("Object_Size must be a multiple of 8", Expr);
end if;
Set_Esize (U_Ent, Size);
[Ada] Proper handling of Raise_Expression nodes in Ada 2012
A Raise_Expression is expected to be of any type, and can appear as a component
of any expression. This patch introduces a new type Raise_Type, that is the
initial type of such a node prior to full resolution. A Raise_Expression node
must eventually carry the type imposed by the context. If the type of the
context itself is Raise_Type this indicates that the expression is ambiguous
and must be rejected, as in (raise Constraint_Error) /= (raise Storage_Error).
Compiling raise_ambig.ads must yield:
raise_ambig.ads:2:17: cannot find unique type for raise expression
raise_ambig.ads:2:45: cannot find unique type for raise expression
---
package Raise_Ambig is
B : Boolean := (raise constraint_error) /= (raise storage_error);
end;
--
The following must compile quietly:
---
package CaseExprRaise is
B : constant BOOLEAN :=
(case false is
when False => raise Constraint_Error,
when True => raise Constraint_Error);
X : Integer := (raise constraint_error) + (raise storage_error);
Y : Integer := (raise constraint_error) + 1;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Ed Schonberg
* stand.ads: Raise_Type: new predefined entity, used as the type
of a Raise_Expression prior to resolution.
* cstand.adb: Build entity for Raise_Type.
* sem_ch11.adb (Analyze_Raise_Expression): use Raise_Type as the
initial type of the node.
* sem_type.adb (Covers): Raise_Type is compatible with all
other types.
* sem_res.adb (Resolve): Remove special handling of Any_Type on
Raise_Expression nodes.
(Resolve_Raise_Expression): Signal ambiguity if the type of the
context is still Raise_Type.
Index: sem_type.adb
===
--- sem_type.adb(revision 207879)
+++ sem_type.adb(working copy)
@@ -1128,6 +1128,11 @@
elsif BT2 = Any_Type then
return True;
+ -- A Raise_Expressions is legal in any expression context.
+
+ elsif BT2 = Raise_Type then
+ return True;
+
-- A packed array type covers its corresponding non-packed type. This is
-- not legitimate Ada, but allows the omission of a number of otherwise
-- useless unchecked conversions, and since this can only arise in
Index: sem_res.adb
===
--- sem_res.adb (revision 207942)
+++ sem_res.adb (working copy)
@@ -2060,18 +2060,9 @@
Analyze_Dimension (N);
return;
- -- A Raise_Expression takes its type from context. The Etype was set
- -- to Any_Type, reflecting the fact that the expression itself does
- -- not specify any possible interpretation. So we set the type to the
- -- resolution type here and now. We need to do this before Resolve sees
- -- the Any_Type value.
+ -- Any case of Any_Type as the Etype value means that we had a
+ -- previous error.
- elsif Nkind (N) = N_Raise_Expression then
- Set_Etype (N, Typ);
-
- -- Any other case of Any_Type as the Etype value means that we had
- -- a previous error.
-
elsif Etype (N) = Any_Type then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
return;
@@ -7405,6 +7396,16 @@
Check_Fully_Declared_Prefix (Typ, P);
P_Typ := Empty;
+ -- A useful optimization: check whether the dereference denotes an
+ -- element of a container, and if so rewrite it as a call to the
+ -- corresponding Element function.
+ -- Disabled for now, on advice of ARG. A more restricted form of the
+ -- predicate might be acceptable ???
+
+ -- if Is_Container_Element (N) then
+ -- return;
+ -- end if;
+
if Is_Overloaded (P) then
-- Use the context type to select the prefix that has the correct
@@ -8816,7 +8817,12 @@
procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is
begin
- Set_Etype (N, Typ);
+ if Typ = Raise_Type then
+ Error_Msg_N ("cannot find unique type for raise expression", N);
+ Set_Etype (N, Any_Type);
+ else
+ Set_Etype (N, Typ);
+ end if;
end Resolve_Raise_Expression;
---
Index: cstand.adb
===
--- cstand.adb (revision 207879)
+++ cstand.adb (working copy)
@@ -1321,6 +1321,13 @@
Set_First_Index (Any_String, Index);
end;
+ Raise_Type := New_Standard_Entity;
+ Decl := New_Node (N_Full_Type_Declaration, Stloc);
+ Set_Defining_Identifier (Decl, Raise_Type);
+ Set_Scope (Raise_Type, Standard_Standard);
+ Build_Signed_Integer_Type (Raise_Type, Standard_Integer_Size);
+ Make_Name (Raise_Type, "any type");
+
Standard_Integer_8 := New_Standard_Entity;
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set
[Ada] Issue with SPARK aspects and generics
This patch corrects the propagation of various SPARK aspects from a generic
template to an instance.
-- Source --
-- values.ads
package Values is
In_1 : Integer := 1234;
end Values;
-- gen.ads
with Values; use Values;
generic
package Gen
with Abstract_State=> State,
Initializes => Out_1,
Initial_Condition => (Out_1 = 5678)
is
Out_1 : Integer := 5678;
procedure Proc (In_2 : Integer; Out_2 : out Integer)
with Global => (Input => In_1,
In_Out => State,
Output => Out_1),
Depends => ((Out_1, Out_2, State) => (In_1, In_2, State));
end Gen;
-- gen.adb
package body Gen
with Refined_State => (State => (In_3, Out_3))
is
In_3 : Integer := 1;
Out_3 : Integer := 2;
procedure Proc (In_2 : Integer; Out_2 : out Integer)
with Refined_Global => (Input => (In_1, In_3),
Output => (Out_1, Out_3)),
Refined_Depends => ((Out_1, Out_2, Out_3) => (In_1, In_2, In_3))
is begin null; end Proc;
end Gen;
-- inst.ads
with Gen;
package Inst is new Gen;
-
-- Compilation --
-
$ gcc -c inst.ads
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Hristian Kirtchev
* aspects.adb (Exchange_Aspects): New routine.
* aspects.ads (Exchange_Aspects): New routine.
* atree.adb (Rewrite): Do not check whether the save node has
aspects as it never will, instead check the node about to be clobbered.
* einfo.adb (Write_Field25_Name): Abstract_States can appear in
entities of generic packages.
* sem_ch6.adb (Analyze_Expression_Function): Fix the parent
pointer of an aspect specification list after rewriting takes place.
* sem_ch7.adb (Analyze_Package_Body_Helper): Swap the aspect
specifications of the generic template and the copy used for analysis.
* sem_ch12.adb (Analyze_Generic_Package_Declaration): Swap
the aspect specifications of the generic template and the
copy used for analysis.
(Analyze_Package_Instantiation): Propagate the aspect specifications
from the generic template to the instantiation.
(Build_Instance_Compilation_Unit_Nodes): Propagate the aspect
specifications from the generic template to the instantiation.
* sem_ch13.adb (Analyze_Aspect_Specifications): Handle aspects
Abstract_State, Initializes and Initial_Condition when they
apply to a package instantiation.
Index: sem_ch7.adb
===
--- sem_ch7.adb (revision 207879)
+++ sem_ch7.adb (working copy)
@@ -327,6 +327,11 @@
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Rewrite (N, New_N);
+ -- Once the contents of the generic copy and the template are
+ -- swapped, do the same for their respective aspect specifications.
+
+ Exchange_Aspects (N, New_N);
+
-- Update Body_Id to point to the copied node for the remainder of
-- the processing.
Index: einfo.adb
===
--- einfo.adb (revision 207879)
+++ einfo.adb (working copy)
@@ -9290,7 +9290,8 @@
procedure Write_Field25_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Package=>
+ when E_Generic_Package|
+ E_Package=>
Write_Str ("Abstract_States");
when E_Variable =>
Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 207942)
+++ sem_ch12.adb(working copy)
@@ -3019,6 +3019,11 @@
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N);
+
+ -- Once the contents of the generic copy and the template are swapped,
+ -- do the same for their respective aspect specifications.
+
+ Exchange_Aspects (N, New_N);
Id := Defining_Entity (N);
Generate_Definition (Id);
@@ -3088,7 +3093,6 @@
Check_References (Id);
end if;
end if;
-
end Analyze_Generic_Package_Declaration;
@@ -3598,7 +3602,7 @@
Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
- Name => New_Occurrence_Of (Act_Decl_Id, Loc));
+ Name => New_Occurrence_Of (Act_Decl_Id, Loc));
Append (Unit_Renaming, Renaming_List);
@@ -3616,6 +3620,14 @@
Make_Package_Declaration (Loc,
Specification => Act_Spec);
+ -- Propagate
[Ada] Internal access to Reason for Warnings Off
This is an internal change to allow retrieval of the Reason argument
for a given message suppressed by Warnings (Off). No functional effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Robert Dewar
* errout.adb (Set_Warnings_Mode_Off): Add Reason argument.
(Set_Specific_Warning_Off): Add Reason argument.
* errout.ads (Set_Warnings_Mode_Off): Add Reason argument.
(Set_Specific_Warning_Off): Add Reason argument.
* erroutc.adb (Warnings_Entry): Add Reason field
(Specific_Warning_Entry): Add Reason field.
(Warnings_Suppressed): return String_Id for Reason.
(Warning_Specifically_Suppressed): return String_Id for Reason.
* erroutc.ads (Warnings_Entry): Add Reason field.
(Specific_Warning_Entry): Add Reason field.
(Set_Specific_Warning_Off): Add Reason argument.
(Set_Warnings_Mode_Off): Add Reason argument.
(Warnings_Suppressed): return String_Id for Reason.
(Warning_Specifically_Suppressed): return String_Id for Reason.
* errutil.adb (Warnings_Suppressed): returns String_Id for Reason
(Warning_Specifically_Suppressed): returns String_Id for Reason
* gnat_rm.texi: Document that Warning parameter is string literal
or a concatenation of string literals.
* par-prag.adb: New handling for Reason argument.
* sem_prag.adb (Analyze_Pragma, case Warning): New handling
for Reason argument.
* sem_util.ads, sem_util.adb (Get_Reason_String): New procedure.
* sem_warn.ads (Warnings_Off_Entry): Add reason field.
* stringt.adb: Set Null_String_Id.
* stringt.ads (Null_String_Id): New constant.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 207905)
+++ gnat_rm.texi(working copy)
@@ -7381,7 +7381,7 @@
pragma Warnings (static_string_EXPRESSION [,REASON]);
pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
-REASON ::= Reason => static_string_EXPRESSION
+REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
@end smallexample
@noindent
Index: stringt.adb
===
--- stringt.adb (revision 207879)
+++ stringt.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
@@ -472,4 +472,12 @@
end if;
end Write_String_Table_Entry;
+-- Setup the null string
+
+pragma Warnings (Off); -- kill strange warning from code below ???
+
+begin
+ Start_String;
+ Null_String_Id := End_String;
+
end Stringt;
Index: stringt.ads
===
--- stringt.ads (revision 207879)
+++ stringt.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
@@ -48,6 +48,9 @@
-- value for two identical strings stored separately and also cannot count on
-- the two Id values being different.
+ Null_String_Id : String_Id;
+ -- Gets set to a null string with length zero
+
--
-- String Table Access Subprograms --
--
Index: sem_prag.adb
===
--- sem_prag.adb(revision 207942)
+++ sem_prag.adb(working copy)
@@ -20815,14 +20815,17 @@
-- REASON ::= Reason => Static_String_Expression
- when Pragma_Warnings => Warnings : begin
+ when Pragma_Warnings => Warnings : declare
+Reason : String_Id;
+
+ begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
-- See if last argument is labeled Reason. If so, make sure we
--- have a static string expression, but
[Ada] Duplicate projects due to symbolic links
When the same projec is imported by several projects in the project tree through different paths that includes symbolic links, the Project Manager may reported an error indicating that two different projects have the same name. This is corrected by this patch. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Vincent Celier * prj-part.adb (Parse_Single_Project): Use the fully resolved project path, with all symbolic links resolved, to check if the same project is imported with a different unresolved path. * prj-tree.ads (Project_Name_And_Node): Component Canonical_Path changed to Resolved_Path to reflect that all symbolic links are resolved. Index: prj-part.adb === --- prj-part.adb(revision 207879) +++ prj-part.adb(working copy) @@ -1126,8 +1126,8 @@ if Project_Qualifier_Of (Imported, In_Tree) = Aggregate then Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); - Error_Msg -(Flags, "cannot import aggregate project %%", Token_Ptr); + Error_Msg + (Flags, "cannot import aggregate project %%", Token_Ptr); exit; end if; @@ -1280,6 +1280,7 @@ Normed_Path_Name: Path_Name_Type; Canonical_Path_Name : Path_Name_Type; + Resolved_Path_Name : Path_Name_Type; Project_Directory : Path_Name_Type; Project_Scan_State : Saved_Project_Scan_State; Source_Index: Source_File_Index; @@ -1329,6 +1330,20 @@ Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; Canonical_Path_Name := Name_Find; + + if Opt.Follow_Links_For_Files then +Resolved_Path_Name := Canonical_Path_Name; + + else +Name_Len := 0; +Add_Str_To_Name_Buffer + (Normalize_Pathname + (Canonical_Path, + Resolve_Links => True, + Case_Sensitive => False)); +Resolved_Path_Name := Name_Find; + end if; + end; if Has_Circular_Dependencies @@ -1351,7 +1366,7 @@ while A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node loop - if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then + if A_Project_Name_And_Node.Resolved_Path = Resolved_Path_Name then if Extended then if A_Project_Name_And_Node.Extended then @@ -1773,6 +1788,17 @@ if Present (Extended_Project) then + if Project_Qualifier_Of (Extended_Project, In_Tree) = + Aggregate + then +Error_Msg_Name_1 := + Name_Id (Path_Name_Of (Extended_Project, In_Tree)); +Error_Msg + (Env.Flags, + "cannot extend aggregate project %%", + Location_Of (Project, In_Tree)); + end if; + -- A project that extends an extending-all project is -- also an extending-all project. @@ -1987,7 +2013,7 @@ E => (Name => Name_Of_Project, Display_Name => Display_Name_Of_Project, Node => Project, - Canonical_Path => Canonical_Path_Name, + Resolved_Path => Resolved_Path_Name, Extended => Extended, From_Extended => From_Extended /= None, Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree))); Index: prj-tree.adb === --- prj-tree.adb(revision 207893) +++ prj-tree.adb(working copy) @@ -2922,7 +2922,7 @@ Prj.Tree.Tree_Private_Part.Project_Name_And_Node' (Name => Name, Display_Name => Name, - Canonical_Path => No_Path, + Resolved_Path => No_Path, Node => Project, Extended => False, From_Extended => False, Index: prj-tree.ads === --- prj-tree.ads(revision 207879) +++ prj-tree.ads(working copy) @@ -1469,7 +1469,7 @@ Node : Project_Node_Id; -- Node of the project in table Project_Nodes - Canonical_Path : Path_Name_Type; + Resolved_Path : Path_Name_Type; -- Resolved and canonical path of a real project file. -- No_Name in case of virtual projects. @@ -1488,7 +1488,7 @@ (Name => No_Name, Display_Name => No_Name,
[Ada] Do not perform expansion of generics even in GNATprove mode
In GNATprove mode for formal verification, some treatment typically only done during expansion needs to be performed on the tree, but it should not be applied inside generics. Otherwise, this breaks the name resolution mechanism for genetic instances. This completes a previous similar fix. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Yannick Moy * expander.adb (Expand): Do nothing inside generics. * sem_aggr.adb (Aggregate_Constraint_Checks): Do nothing inside generics. Index: sem_aggr.adb === --- sem_aggr.adb(revision 207879) +++ sem_aggr.adb(working copy) @@ -459,7 +459,9 @@ -- added in the tree, so that the formal verification can rely on those -- to be present. - if not (Expander_Active or GNATprove_Mode) or In_Spec_Expression then + if not Expander_Active +and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) + then return; end if; Index: expander.adb === --- expander.adb(revision 207879) +++ expander.adb(working copy) @@ -90,7 +90,8 @@ -- analysis, in which case Full_Analysis = True or a pre-analysis in -- which case Full_Analysis = False. See the spec of Sem for more info -- on this. Additionally, the GNATprove_Mode flag indicates that a light - -- expansion for formal verification should be used. + -- expansion for formal verification should be used. This expansion is + -- never done inside generics. -- The second reason for the Expander_Active flag to be False is that -- we are performing a pre-analysis. During pre-analysis all expansion @@ -108,7 +109,9 @@ -- given that the expansion actions that would normally process it will -- not take place. This prevents cascaded errors due to stack mismatch. - if not (Expander_Active or (Full_Analysis and GNATprove_Mode)) then + if not Expander_Active +and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) + then Set_Analyzed (N, Full_Analysis); if Serious_Errors_Detected > 0 and then Scope_Is_Transient then
[Ada] Fix removal of side-effects in GNATprove mode
In the GNATprove mode for formal verification, side-effects are removed from expressions when the corresponding procedure is called in the frontend. This should only be done when not inside a generic, which is both useless and harmful as it deactivates the mechanism for name resolution of generic instances. Now fixed. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Yannick Moy * exp_util.adb (Remove_Side_Effects): Do not remove side-effects inside a generic. Index: exp_util.adb === --- exp_util.adb(revision 207892) +++ exp_util.adb(working copy) @@ -6638,9 +6638,12 @@ begin -- Handle cases in which there is nothing to do. In GNATprove mode, -- removal of side effects is useful for the light expansion of - -- renamings. + -- renamings. This removal should only occur when not inside a + -- generic and not doing a pre-analysis. - if not (Expander_Active or (Full_Analysis and GNATprove_Mode)) then + if not Expander_Active +and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) + then return; end if;
[Ada] Legality rules for Synchronization aspect on protected operations
This patch detects additional errors when a Synchronization aspect on an
overriding protected operation does not match the given aspect on the
overridden operation of an ancestor interface.
Compiling b95000g.ads must yield:
b95000g.ads:29:13:
type "Lock_Type" must implement abstract subprogram "Unlock" with a
procedure
b95000g.ads:30:17:
overriding operation "Unlock_2" must have synchronization
"BY_PROTECTED_PROCEDURE"
b95000g.ads:32:17:
type "Lock_Type" must implement abstract subprogram "Lock" with an entry
b95000g.ads:33:17:
overriding operation "Lock_2" must have syncrhonization "OPTIONAL"
b95000g.ads:38:14:
overriding operation "Try_Lock" must have syncrhonization "OPTIONAL"
---
-- B95000G.A
--
--*
--
-- OBJECTIVE:
-- Check that primitive procedures of synchronized interfaces with
-- a Synchronization aspect cannot be completed with different callable
-- entity, or can have conflicting
--
-- CHANGE HISTORY:
-- 16 Nov 13 GRB Initial version
--!
package B95000G is
type Spinlock is synchronized interface;
procedure Unlock (L : in out Spinlock) is abstract
with Synchronization => By_Protected_Procedure;
procedure Lock (L : in out Spinlock) is abstract
with Synchronization => By_Entry;
procedure Try_Lock (L : in out Spinlock; Success : out Boolean) is abstract
with Synchronization => Optional;
procedure Unlock_2 (L : in out Spinlock) is abstract
with Synchronization => By_Protected_Procedure;
procedure Lock_2 (L : in out Spinlock) is abstract
with Synchronization => Optional;
protected type Lock_Type is new Spinlock with
entry Unlock; -- ERROR: must be protected procedure
procedure Unlock_2
with Synchronization => Optional; -- ERROR: should be By_Prot_Proc
procedure Lock; -- ERROR: must be entry
procedure Lock_2 with Synchronization => By_Entry; -- ERROR: is procedure
private
Unlocked : Boolean := True;
end Lock_Type;
procedure Try_Lock
(L : in out Lock_Type;
Success : out Boolean)
with Synchronization => By_Entry; -- ERROR: is procedure
end B95000G;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-19 Ed Schonberg
* sem_ch3.adb (Check_Pragma_Implemented): Detect additional
errors when a Synchronization aspect on an overriding protected
operation does not match the given aspect on the overridden
operation of an ancestor interface.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 207879)
+++ sem_ch3.adb (working copy)
@@ -9377,7 +9377,26 @@
Error_Msg_NE
("type & must implement abstract subprogram & with a " &
"procedure", Subp_Alias, Contr_Typ);
+
+elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
+ and then Implementation_Kind (Impl_Subp) /= Impl_Kind
+then
+ Error_Msg_Name_1 := Impl_Kind;
+ Error_Msg_N
+("overriding operation& must have synchronization%",
+ Subp_Alias);
end if;
+
+ -- If primitive has Optional synchronization, overriding operation
+ -- must match if it has an explicit synchronization..
+
+ elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
+ and then Implementation_Kind (Impl_Subp) /= Impl_Kind
+ then
+ Error_Msg_Name_1 := Impl_Kind;
+ Error_Msg_N
+("overriding operation& must have syncrhonization%",
+ Subp_Alias);
end if;
end Check_Pragma_Implemented;
[Ada] Semantics of attribute 'Old in aspect/pragma Contract_Cases
This patch implements rule SPARK RM 6.1.3 (5) which states:
If an Old attribute_reference occurs within a consequence other than the
consequence selected for (later) evaluation as described above, then the
associated implicit constant declaration (see Ada RM 6.1.1) is not
elaborated. [In particular, the prefix of the Old attribute_reference is
not evaluated].
-- Source --
-- old_evaluation.ads
package Old_Evaluation is
procedure Reset_Self;
function Self (Val : Integer) return Integer;
procedure Check_Old (Val : in out Integer)
with Contract_Cases =>
(Val < 0 => Val = Self (Val)'Old - 1,
Val = 0 => Val = Self (Val)'Old,
Val > 0 => Val = Self (Val)'Old + 1);
end Old_Evaluation;
-- old_evaluation.adb
package body Old_Evaluation is
Self_Called : Boolean := False;
procedure Check_Old (Val : in out Integer) is
begin
if Val < 0 then
Val := Val - 1;
elsif Val > 0 then
Val := Val + 1;
end if;
end Check_Old;
procedure Reset_Self is
begin
Self_Called := False;
end Reset_Self;
function Self (Val : Integer) return Integer is
begin
if Self_Called then
raise Program_Error;
else
Self_Called := True;
return Val;
end if;
end Self;
end Old_Evaluation;
-- old_main.adb
with Ada.Text_IO;use Ada.Text_IO;
with Old_Evaluation; use Old_Evaluation;
procedure Old_Main is
procedure Test_Value (Val : Integer) is
Num : Integer := Val;
begin
Reset_Self;
Check_Old (Num);
exception
when others => Put_Line ("ERROR:" & Val'Img & " failed");
end Test_Value;
begin
Test_Value (-2);
Test_Value (0);
Test_Value (5);
end Old_Main;
-
-- Compilation --
-
$ gnatmake -q -gnata old_main.adb
$ ./old_main
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-19 Hristian Kirtchev
* exp_ch6.adb Add with and use clause for Exp_Prag.
(Expand_Contract_Cases): Relocated to Exp_Prag.
* exp_ch6.ads (Expand_Contract_Cases): Relocated to Exp_Prag.
* exp_prag.adb Add with and use clauses for Checks and Validsw.
(Expand_Contract_Cases): Relocated from Exp_Ch6. Update the
structure of the expanded code to showcase the evaluation of
attribute 'Old prefixes. Add local variable Old_Evals. Expand
any attribute 'Old references found within a consequence. Add
circuitry to evaluate the prefixes of attribute 'Old that
belong to a selected consequence.
(Expand_Old_In_Consequence): New routine.
* exp_prag.ads (Expand_Contract_Cases): Relocated from Exp_Ch6.
* sem_attr.adb (Check_Use_In_Contract_Cases): Warn that a
potentially unevaluated prefix is always evaluated.
Index: exp_ch6.adb
===
--- exp_ch6.adb (revision 207890)
+++ exp_ch6.adb (working copy)
@@ -41,6 +41,7 @@
with Exp_Dist; use Exp_Dist;
with Exp_Intr; use Exp_Intr;
with Exp_Pakd; use Exp_Pakd;
+with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
@@ -4118,476 +4119,6 @@
end if;
end Expand_Call;
- ---
- -- Expand_Contract_Cases --
- ---
-
- -- Pragma Contract_Cases is expanded in the following manner:
-
- --subprogram S is
- -- Flag_1 : Boolean := False;
- -- . . .
- -- Flag_N : Boolean := False;
- -- Flag_N+1 : Boolean := False; -- when "others" present
- -- Count: Natural := 0;
-
- --
-
- -- if Case_Guard_1 then
- -- Flag_1 := True;
- -- Count := Count + 1;
- -- end if;
- -- . . .
- -- if Case_Guard_N then
- -- Flag_N := True;
- -- Count := Count + 1;
- -- end if;
-
- -- if Count = 0 then
- -- raise Assertion_Error with "xxx contract cases incomplete";
- --
- -- Flag_N+1 := True; -- when "others" present
-
- -- elsif Count > 1 then
- -- declare
- -- Str0 : constant String :=
- -- "contract cases overlap for subprogram ABC";
- -- Str1 : constant String :=
- -- (if Flag_1 then
- -- Str0 & "case guard at xxx evaluates to True"
- -- else Str0);
- -- StrN : constant String :=
- -- (if Flag_N then
- -- StrN-1 & "case guard at xxx evaluates to True"
- -- else StrN-1);
- -- begin
- -- raise Assertion_Error with StrN;
- -- end;
- -- end if;
-
- -- procedure _Postconditions is
- -- begin
- --
-
- -- i
[Ada] Missing parentheses on [Refined_]Global and [Refined_]Depends
This patch modifies the parser to detect missing parentheses on SPARK aspects
Global, Depends, Refined_Global and Refined_Depends.
-- Source --
-- malformed_contracts.ads
package Malformed_Contracts
with Abstract_State => (State_1, State_2)
is
procedure OK_1
with Global => State_1;
procedure OK_2
with Global => (State_1, State_2);
procedure Error_0
with Global => State_1, State_2;
procedure Error_1
with Global => Input => State_1;
procedure Error_2
with Global => (Input => State_1;
procedure Error_3
with Global => Input => State_1, In_Out => State_2;
procedure Error_4
with Global => (Input => State_1, In_Out => State_2;
procedure Error_5
with Global => (In_Out => State_1),
Depends => State_1 => State_1;
procedure Error_6
with Global => (In_Out => State_1),
Depends => (State_1 => State_1;
procedure Error_7
with Global => (Input => State_1, In_Out => State_2),
Depends => State_2 => State_1, null => State_2;
procedure Error_8
with Global => (Input => State_1, In_Out => State_2),
Depends => (State_2 => State_1, null => State_2;
end Malformed_Contracts;
-- Compilation and output --
$ gcc -c malformed_contracts.ads
malformed_contracts.ads:11:21: missing "("
malformed_contracts.ads:14:21: missing "("
malformed_contracts.ads:17:38: ";" should be ","
malformed_contracts.ads:20:21: missing "("
malformed_contracts.ads:23:57: ";" should be ","
malformed_contracts.ads:27:23: missing "("
malformed_contracts.ads:31:41: ";" should be ","
malformed_contracts.ads:35:23: missing "("
malformed_contracts.ads:39:60: missing ")"
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-19 Hristian Kirtchev
* par.adb Alphabetize the routines in Par.Sync.
(Resync_Past_Malformed_Aspect): New routine.
* par-ch13.adb (Get_Aspect_Specifications): Alphabetize local
variables. Code and comment reformatting. Detect missing
parentheses on aspects [Refined_]Global and [Refined_]Depends
with a non-null definition.
* par-sync.adb: Alphabetize all routines in this separate unit.
(Resync_Past_Malformed_Aspect): New routine.
Index: par-sync.adb
===
--- par-sync.adb(revision 207879)
+++ par-sync.adb(working copy)
@@ -148,47 +148,75 @@
end if;
end Resync_Init;
- ---
- -- Resync_Past_Semicolon --
- ---
+ --
+ -- Resync_Past_Malformed_Aspect --
+ --
- procedure Resync_Past_Semicolon is
+ procedure Resync_Past_Malformed_Aspect is
begin
Resync_Init;
loop
- -- Done if we are at a semicolon
+ -- A comma may separate two aspect specifications, but it may also
+ -- delimit multiple arguments of a single aspect.
- if Token = Tok_Semicolon then
-Scan; -- past semicolon
+ if Token = Tok_Comma then
+declare
+ Scan_State : Saved_Scan_State;
+
+begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past comma
+
+ -- The identifier following the comma is a valid aspect, the
+ -- current malformed aspect has been successfully skipped.
+
+ if Token = Tok_Identifier
+ and then Get_Aspect_Id (Token_Name) /= No_Aspect
+ then
+ Restore_Scan_State (Scan_State);
+ exit;
+
+ -- The comma is delimiting multiple arguments of an aspect
+
+ else
+ Restore_Scan_State (Scan_State);
+ end if;
+end;
+
+ -- An IS signals the last aspect specification when the related
+ -- context is a body.
+
+ elsif Token = Tok_Is then
exit;
- -- Done if we are at a token which normally appears only after
- -- a semicolon. One special glitch is that the keyword private is
- -- in this category only if it does NOT appear after WITH.
+ -- A semicolon signals the last aspect specification
- elsif Token in Token_Class_After_SM
-and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
- then
+ elsif Token = Tok_Semicolon then
exit;
- -- Otherwise keep going
+ -- In the case of a mistyped semicolon, any token which follows a
+ -- semicolon signals the last aspect specification.
- else
-Scan;
+ elsif Token in Token_Class_After_SM then
+exit;
end if;
+
+ -- Keep on resyncing
+
+ Scan;
end loop;
-- Fall out of loop wit
[Ada] GNAT driver and externally built library project files
When the GNAT driver is invoked to bind a main of a project file, and there are externally built library projects in the closure of the main project file, the invocation of gnatbind may fail if the object directory does not contain any ALI files. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Vincent Celier * gnatcmd.adb (GNATCmd): Always replace the object dirs of imported library projects with the library ALI dirs, when setting the object paths. * prj-env.ads (Ada_Objects_Path): Correct comments about argument Including_Libraries. Index: gnatcmd.adb === --- gnatcmd.adb (revision 207879) +++ gnatcmd.adb (working copy) @@ -1040,6 +1040,7 @@ "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; + -- -- Process_Link -- -- @@ -2106,7 +2107,7 @@ -- Set up the env vars for project path files Prj.Env.Set_Ada_Paths - (Project, Project_Tree, Including_Libraries => False); + (Project, Project_Tree, Including_Libraries => True); -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- a configuration pragmas file, if necessary. Index: prj-env.adb === --- prj-env.adb (revision 207879) +++ prj-env.adb (working copy) @@ -1681,8 +1681,6 @@ Path : Path_Name_Type; begin - -- ??? This is almost the equivalent of For_All_Source_Dirs - if Process_Source_Dirs then -- Add to path all source directories of this project if there are Index: prj-env.ads === --- prj-env.ads (revision 207879) +++ prj-env.ads (working copy) @@ -92,7 +92,7 @@ Including_Libraries : Boolean := True) return String_Access; -- Get the ADA_OBJECTS_PATH of a Project file. For the first call with the -- exact same parameters, compute it and cache it. When Including_Libraries - -- is False, the object directory of a library project is replaced with the + -- is True, the object directory of a library project is replaced with the -- library ALI directory of this project (usually the library directory of -- the project, except when attribute Library_ALI_Dir is declared) except -- when the library ALI directory does not contain any ALI file.
[Ada] Incorrect error on valid global refinement
This patch updates the analysis of aspect/pragma Refined_Global to interpret states and variables with an encapsulating state as constituents only when the related state has visible refinement. -- Source -- -- parent.ads package Parent with Abstract_State => State is procedure Dummy; private Var : Integer := 0 with Part_Of => State; end Parent; -- parent.adb with Parent.Priv_Child; package body Parent with Refined_State => (State => (Var, Parent.Priv_Child.Priv_State)) is procedure Dummy is begin null; end Dummy; end Parent; -- parent-priv_child.ads private package Parent.Priv_Child with Abstract_State => (Priv_State with Part_Of => State) is procedure OK (Param : Integer) with Global => (In_Out => (Var, Priv_State)); end Parent.Priv_Child; -- parent-priv_child.adb package body Parent.Priv_Child with Refined_State => (Priv_State => Priv_Var) is Priv_Var : Integer := 0; procedure OK (Param : Integer) with Refined_Global => (In_Out => (Var, Priv_Var)) is begin null; end OK; end Parent.Priv_Child; - -- Compilation -- - $ gcc -c parent-priv_child.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Hristian Kirtchev * sem_prag.adb (Check_Refined_Global_Item): A state or variable acts as a constituent only it is part of an encapsulating state and the state has visible refinement. Index: sem_prag.adb === --- sem_prag.adb(revision 207884) +++ sem_prag.adb(working copy) @@ -22610,10 +22610,13 @@ -- Start of processing for Check_Refined_Global_Item begin --- The state or variable acts as a constituent of a state, collect --- it for the state completeness checks performed later on. +-- When the state or variable acts as a constituent of another +-- state with a visible refinement, collect it for the state +-- completeness checks performed later on. -if Present (Encapsulating_State (Item_Id)) then +if Present (Encapsulating_State (Item_Id)) + and then Has_Visible_Refinement (Encapsulating_State (Item_Id)) +then if Global_Mode = Name_Input then Add_Item (Item_Id, In_Constits);
[Ada] Error recovery in task body
This patch fixes a crash in a task body with a single statement missing a terminating semicolon. The tree can be repaired locally so further compilation can proceed. Compiling libthr3.adb must yield: libthr3.adb:10:18: missing ";" libthr3.adb:13:04: warning: no accept for entry "Test" --- procedure Libthr3 is task type TSK; task Driver is entry Test; end Driver; task body TSK is begin Driver.Test -- Missing ; gives GNAT BUG DETECTED box end TSK; task body Driver is P : access TSK; begin P := new TSK; end Driver; begin null; end Libthr3; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Ed Schonberg * par-ch9.adb (P_Task): Add a null statement to produce a well-formed task body when due to a previous syntax error the statement list is empty. Index: par-ch9.adb === --- par-ch9.adb (revision 207879) +++ par-ch9.adb (working copy) @@ -144,6 +144,17 @@ end if; Parse_Decls_Begin_End (Task_Node); + +-- The statement list of a task body needs to include at least a +-- null statement, so if a parsing error produces an empty list, +-- patch it now. + +if + No (First (Statements (Handled_Statement_Sequence (Task_Node +then + Set_Statements (Handled_Statement_Sequence (Task_Node), + New_List (Make_Null_Statement (Token_Ptr))); +end if; end if; return Task_Node;
[Ada] Accept a constituent in a null dependency clause
This patch implements the following SPARK RM rule from 7.2.5 (3g): at least one of its constituents shall be denoted in the input_list of a null_dependency_clause; or -- Source -- -- null_dependency.ads package Null_Dependency with Abstract_State => (Input_State, Output_State) is procedure OK_1 with Global => (Input => Input_State), Depends => (null => Input_State); procedure OK_2 with Global => (Input => Input_State, Output => Output_State), Depends => (Output_State => Input_State); end Null_Dependency; -- null_dependency.adb package body Null_Dependency with Refined_State => (Input_State => (C1, C2), Output_State => (C3, C4)) is C1, C2, C3, C4 : Integer := 0; procedure OK_1 with Refined_Global => (Input => C1), Refined_Depends => (null => C1) is begin null; end OK_1; procedure OK_2 with Refined_Global => (Input => (C1, C2), Output => (C3, C4)), Refined_Depends => ((C3, C4) => C1, null=> C2) is begin null; end OK_2; end Null_Dependency; - -- Compilation -- - $ gcc -c null_dependency.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-19 Hristian Kirtchev * sem_prag.adb (Check_Dependency_Clause): Account for the case where a state with a non-null refinement matches a null output list. Comment reformatting. (Inputs_Match): Copy a solitary input to avoid an assertion failure when trying to match the same input in multiple clauses. Index: sem_prag.adb === --- sem_prag.adb(revision 207879) +++ sem_prag.adb(working copy) @@ -21434,16 +21434,38 @@ elsif Has_Non_Null_Refinement (Dep_Id) then Has_Refined_State := True; - if Is_Entity_Name (Ref_Output) then + -- Account for the case where a state with a non-null + -- refinement matches a null output list: + + --Refined_State => (State_1 => (C1, C2), + --State_2 => (C3, C4)) + --Depends => (State_1 => State_2) + --Refined_Depends => (null=> C3) + + if Nkind (Ref_Output) = N_Null + and then Inputs_Match + (Dep_Clause => Dep_Clause, + Ref_Clause => Ref_Clause, + Post_Errors => False) + then +Has_Constituent := True; + +-- Note that the search continues after the clause is +-- removed from the pool of candidates because it may +-- have been normalized into multiple simple clauses. + +Remove (Ref_Clause); + + -- Otherwise the output of the refinement clause must be + -- a valid constituent of the state: + + --Refined_State => (State => (C1, C2)) + --Depends => (State => ) + --Refined_Depends => (C1=> ) + + elsif Is_Entity_Name (Ref_Output) then Ref_Id := Entity_Of (Ref_Output); --- The output of the refinement clause is a valid --- constituent of the state. Remove the clause from --- the pool of candidates if both input lists match. --- Note that the search continues because one clause --- may have been normalized into multiple clauses as --- per the example above. - if Ekind_In (Ref_Id, E_Abstract_State, E_Variable) and then Present (Encapsulating_State (Ref_Id)) and then Encapsulating_State (Ref_Id) = Dep_Id @@ -21453,6 +21475,12 @@ Post_Errors => False) then Has_Constituent := True; + + -- Note that the search continues after the clause + -- is removed from the pool of candidates because + -- it may have been normalized into multiple simple + -- clauses. + Remove (Ref_Clause); end if; end if; @@ -21819,12 +21847,13 @@ begin -- Construct a list of all refinement inputs. Note that the input -- list is copied because the algorithm modifies its content
[Ada] Use of attributes 'Old and 'Result and local entities in another 'Old
This patch implements the following sentence from Ada RM 6.1.1 (27/3):
The prefix of an Old attribute_reference shall not contain a Result
attribute_reference, nor an Old attribute_reference, nor a use of an entity
declared within the postcondition expression but not within prefix itself
(for example, the loop parameter of an enclosing quantified_expression).
-- Source --
-- semantics.ads
package Semantics is
Stuff : array (1 .. 5) of Integer;
procedure Local_Entity_In_Spec
with Post =>
(for all Index in 1 .. 5 =>
Stuff (Index) = Stuff (Index)'Old - 1);
procedure Nested_Old_In_Spec (Param : in out Integer)
with Post =>
Param = Param'Old'Old;
end Semantics
-- semantics.adb
package body Semantics is
procedure Local_Entity_In_Body
with Post =>
(for all Index in 1 .. 5 =>
Stuff (Index) = Stuff (Index)'Old - 1)
is begin null; end Local_Entity_In_Body;
procedure Local_Entity_In_Spec is begin null; end Local_Entity_In_Spec;
procedure Nested_Old_In_Body (Param : in out Integer)
with Post =>
Param = Param'Old'Old
is begin null; end Nested_Old_In_Body;
procedure Nested_Old_In_Spec (Param : in out Integer) is
begin null; end Nested_Old_In_Spec;
end Semantics;
-- Compilation and output --
$ gcc -c semantics.adb
semantics.adb:5:34: prefix of attribute "Old" cannot reference local entities
semantics.adb:12:21: attribute "Old" cannot appear in the prefix of attribute
"Old"
semantics.ads:7:34: prefix of attribute "Old" cannot reference local entities
semantics.ads:11:21: attribute "Old" cannot appear in the prefix of attribute
"Old"
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-18 Hristian Kirtchev
* sem_attr.adb (Analyze_Attribute): Comment
and code reformatting. Use separate routines to check the
legality of attribute 'Old in certain pragmas. Verify
the use of 'Old, 'Result and locally declared entities
within the prefix of 'Old.
(Check_References_In_Prefix): New routine.
(Check_Use_In_Contract_Cases): New routine.
(Check_Use_In_Test_Case): New routine.
Index: sem_attr.adb
===
--- sem_attr.adb(revision 207558)
+++ sem_attr.adb(working copy)
@@ -4373,6 +4373,137 @@
-
when Attribute_Old => Old : declare
+ procedure Check_References_In_Prefix (Subp_Id : Entity_Id);
+ -- Inspect the contents of the prefix and detect illegal uses of a
+ -- nested 'Old, attribute 'Result or a use of an entity declared in
+ -- the related postcondition expression. Subp_Id is the subprogram to
+ -- which the related postcondition applies.
+
+ procedure Check_Use_In_Contract_Cases (Prag : Node_Id);
+ -- Perform various semantic checks related to the placement of the
+ -- attribute in pragma Contract_Cases.
+
+ procedure Check_Use_In_Test_Case (Prag : Node_Id);
+ -- Perform various semantic checks related to the placement of the
+ -- attribute in pragma Contract_Cases.
+
+
+ -- Check_References_In_Prefix --
+
+
+ procedure Check_References_In_Prefix (Subp_Id : Entity_Id) is
+function Check_Reference (Nod : Node_Id) return Traverse_Result;
+-- Detect attribute 'Old, attribute 'Result of a use of an entity
+-- and perform the appropriate semantic check.
+
+-
+-- Check_Reference --
+-
+
+function Check_Reference (Nod : Node_Id) return Traverse_Result is
+begin
+ -- Attributes 'Old and 'Result cannot appear in the prefix of
+ -- another attribute 'Old.
+
+ if Nkind (Nod) = N_Attribute_Reference
+ and then Nam_In (Attribute_Name (Nod), Name_Old,
+Name_Result)
+ then
+ Error_Msg_Name_1 := Attribute_Name (Nod);
+ Error_Msg_Name_2 := Name_Old;
+ Error_Msg_N
+("attribute % cannot appear in the prefix of attribute %",
+ Nod);
+ return Abandon;
+
+ -- Entities mentioned within the prefix of attribute 'Old must
+ -- be global to the related postcondition. If this is not the
+ -- case, then the scope of the local entity is be nested within
+ -- that of the subprogram.
+
+ elsif Nkind (Nod) = N_Identifier
+ and then Present (Entity (Nod))
+ and then Scope_Within (Scope (Entity (Nod)), Subp_Id)
+
[Ada] Reduce use of N_Reference nodes in generated code
This is an internal optimization that reduces the number of cases in which we generate N_Reference nodes. Generally has no effect on functional behavior, but the following test: 1. function StrangeRef (A, B : Integer) return Integer is 2.X : Integer; 3. begin 4.X := Integer'Max ((if A > 4 then B else 15), B); 5.return X; 6. end StrangeRef; compiled with -gnatG and -gnatd.u can be used to see that we do properly optimize this case and avoid generating an N_Reference node which is what we used to do: Source recreated from tree for Strangeref (body) function strangeref (a : integer; b : integer) return integer is x : integer; begin R1b : constant integer := (if a > 4 then integer(b) else 15); x := (if (R1b) >= b then (R1b) else integer(b)); return x; end strangeref; Previously R1b generated an N_Reference node Tested on x86_64-pc-linux-gnu, committed on trunk 2014-02-18 Robert Dewar * exp_attr.adb: Minor reformatting. * exp_ch4.ads, exp_ch4.adb (Expand_N_Reference): New procedure. * exp_util.adb (Remove_Side_Effects): Add conditional expressions as another case where we don't generate N_Reference nodes for primitive types. * expander.adb (Expand): Add call to Expand_N_Reference. Index: exp_util.adb === --- exp_util.adb(revision 207537) +++ exp_util.adb(working copy) @@ -6972,17 +6972,28 @@ Scope_Suppress.Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function call, an attribute reference, an - -- allocator, or an operator. And if we have a volatile reference and - -- Name_Req is not set (see comments above for Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference, a + -- conditional expression, an allocator, or an operator. And if we have + -- a volatile reference and Name_Req is not set (see comments above for + -- Side_Effect_Free). if Is_Elementary_Type (Exp_Type) + +-- Note: this test is rather mysterious??? Why can't we just test ONLY +-- Is_Elementary_Type and be done with it. If we try that approach, we +-- get some failures (infinite recursions) from the Duplicate_Subexpr +-- call at the end of Checks.Apply_Predicate_Check. To be +-- investigated ??? + and then (Variable_Ref - or else Nkind_In (Exp, N_Function_Call, - N_Attribute_Reference, - N_Allocator) + or else Nkind_In (Exp, N_Attribute_Reference, + N_Allocator, + N_Case_Expression, + N_If_Expression, + N_Function_Call) or else Nkind (Exp) in N_Op - or else (not Name_Req and then Is_Volatile_Reference (Exp))) + or else (not Name_Req + and then Is_Volatile_Reference (Exp))) then Def_Id := Make_Temporary (Loc, 'R', Exp); Set_Etype (Def_Id, Exp_Type); @@ -7230,6 +7241,7 @@ E := Exp; if Nkind (E) = N_Explicit_Dereference then New_Exp := Relocate_Node (Prefix (E)); + else E := Relocate_Node (E); Index: exp_attr.adb === --- exp_attr.adb(revision 207559) +++ exp_attr.adb(working copy) @@ -1132,20 +1132,20 @@ -- copies from being created when the unchecked conversion -- is expanded (which would happen in Remove_Side_Effects -- if Expand_N_Unchecked_Conversion were allowed to call --- Force_Evaluation). The copy could violate Ada semantics --- in cases such as an actual that is an out parameter. --- Note that this approach is also used in exp_ch7 for calls --- to controlled type operations to prevent problems with --- actuals wrapped in unchecked conversions. +-- Force_Evaluation). The copy could violate Ada semantics in +-- cases such as an actual that is an out parameter. Note that +-- this approach is also used in exp_ch7 for calls to controlled +-- type operations to prevent problems with actuals wrapped in +-- unchecked conversions. if Is_Untagged_Derivation (Etype (Expression (Item))) then Set_Assignment_OK (Item); end if; end if; - -- The stream operation to call maybe a renaming created by - -- an attribute definition clause, and may not be frozen yet. - --
Re: [Ada] Use "[warning enabled by default]" for default warnings
> This switches Ada from using [enabled by default] to [warning enabled > by default] for consistency with: > > http://gcc.gnu.org/ml/gcc-patches/2014-02/msg00549.html > > Tested on x86_64-linux-gnu. OK if the above patch goes in? As I just mentioned, this isn't OK at first sight. Arno
