[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 qui...@adacore.com * 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
[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 kirtc...@adacore.com * 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
[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 kirtc...@adacore.com * 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
[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 de...@adacore.com
* 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 has
[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 de...@adacore.com
* 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 Unrestricted_Access attribute
[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 de...@adacore.com
* 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
+This switch activates warnings for
[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 schonb...@adacore.com * 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] 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 qui...@adacore.com * 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 --
[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 cel...@adacore.com * 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] 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 qui...@adacore.com * 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
[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 qui...@adacore.com * 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 qui...@adacore.com * 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
[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 kirtc...@adacore.com * 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] 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 kirtc...@adacore.com * 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 kirtc...@adacore.com * 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;
[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 de...@adacore.com * 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
[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 kirtc...@adacore.com * 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] 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 de...@adacore.com * 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] 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 schonb...@adacore.com * 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] 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 de...@adacore.com
* 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] Crash while processing illegal state refinement
This patch modifies the parser to catch a case where the argument of SPARK aspect Refined_State is not properly parenthesized. -- Source -- -- no_parens.ads package No_Parens with SPARK_Mode = On, Abstract_State = State is pragma Elaborate_Body; end No_Parens; -- no_parens.adb package body No_Parens with SPARK_Mode = On, Refined_State = State = (Speed, Status) is Speed : Integer := 0; Status : Integer := 0; end No_Parens; -- Compilation and output -- $ gcc -c no_parens.adb no_parens.adb:3:25: missing ( Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Hristian Kirtchev kirtc...@adacore.com * par-ch13.adb (Get_Aspect_Specifications): Catch a case where the argument of SPARK aspect Refined_State is not properly parenthesized. Index: par-ch13.adb === --- par-ch13.adb(revision 212640) +++ par-ch13.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- -- @@ -308,8 +308,8 @@ end if; -- Detect a common error where the non-null definition of - -- aspect Depends, Global, Refined_Depends or Refined_Global - -- must be enclosed in parentheses. + -- aspect Depends, Global, Refined_Depends, Refined_Global + -- or Refined_State lacks enclosing parentheses. if Token /= Tok_Left_Paren and then Token /= Tok_Null then @@ -400,6 +400,48 @@ Restore_Scan_State (Scan_State); end if; end; + + -- Refined_State + + elsif A_Id = Aspect_Refined_State then + if Token = Tok_Identifier then +declare + Scan_State : Saved_Scan_State; + +begin + Save_Scan_State (Scan_State); + Scan; -- past state + + -- The refinement contains a constituent, the whole + -- argument of Refined_State must be parenthesized. + + --with Refined_State = State = Constit + + if Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX +(missing (); + Resync_Past_Malformed_Aspect; + + -- Return when the current aspect is the last + -- in the list of specifications and the list + -- applies to a body. + + if Token = Tok_Is then + return Aspects; + end if; + + -- The refinement lacks constituents. Do not flag + -- this case as the error would be misleading. The + -- diagnostic is left to the analysis. + + --with Refined_State = State + + else + Restore_Scan_State (Scan_State); + end if; +end; + end if; end if; end if;
[Ada] Implement No_Standard_Allocators_After_Elaboration
This implements the final definition of the Ada 2012 restriction
No_Standard_Allocators_After_Elaboration. There are two static
cases. First appearence in task body, this one we already had
before (compiled with -gnatj55 -gnatld7)
1. procedure Pmain2 is
2.type P is access all Integer;
3.PV : P;
4.task X;
5.task body X is
6.begin
7. PV := new Integer;
|
violation of restriction
No_Standard_Allocators_After_Elaboration
at gnat.adc:1
8.end;
9. begin
10.null;
11. end;
Second, also a static case, appearence in a parameterless
library level procedure (same switches)
1. procedure Pmain is
2.type R is access all Integer;
3.RV : R;
4. begin
5.RV := new Integer;
|
violation of restriction
No_Standard_Allocators_After_Elaboration
at gnat.adc:1
6. end;
Finally the dynamic case tested at run-time:
1. with Allocate_After_Elab;
2. procedure Allocate_After_Elab_Test is
3. begin
4.Allocate_After_Elab (42);
5. end Allocate_After_Elab_Test;
1. with Ada.Text_IO;
2. procedure Allocate_After_Elab (X : Integer) is
3.type Int_Ptr_Type is access Integer;
4.My_Int_Ptr : Int_Ptr_Type;
5. begin
6.My_Int_Ptr := new Integer'(X);
7.Ada.Text_IO.Put_Line (Have used allocator);
8. end Allocate_After_Elab;
If we run Allocate_After_Elab_Test, we get:
raised PROGRAM_ERROR : standard allocator after elaboration is complete is not
allowed
(No_Standard_Allocators_After_Elaboration restriction active)
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-18 Robert Dewar de...@adacore.com
* gcc-interface/Make-lang.in: Add entry for s-elaall.o
* bcheck.adb (Check_Consistent_Restrictions):
Remove obsolete code checking for violation of
No_Standard_Allocators_After_Elaboration (main program)
* bindgen.adb (Gen_Adainit): Handle
No_Standard_Allocators_After_Elaboration
(Gen_Output_File_Ada): ditto.
* exp_ch4.adb (Expand_N_Allocator): Handle
No_Standard_Allocators_After_Elaboration.
* Makefile.rtl: Add entry for s-elaall
* rtsfind.ads: Add entry for Check_Standard_Allocator.
* s-elaall.ads, s-elaall.adb: New files.
* sem_ch4.adb (Analyze_Allocator): Handle
No_Standard_Allocators_After_Elaboration.
Index: bindgen.adb
===
--- bindgen.adb (revision 212735)
+++ bindgen.adb (working copy)
@@ -739,8 +739,8 @@
if Dispatching_Domains_Used then
WBI ( procedure Freeze_Dispatching_Domains;);
WBI ( pragma Import);
-WBI ((Ada, Freeze_Dispatching_Domains,
- __gnat_freeze_dispatching_domains););
+WBI ((Ada, Freeze_Dispatching_Domains,
+ __gnat_freeze_dispatching_domains););
end if;
WBI ( begin);
@@ -749,6 +749,18 @@
WBI ( end if;);
WBI ( Is_Elaborated := True;);
+ -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
+ -- restriction No_Standard_Allocators_After_Elaboration is active.
+
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
+ then
+WBI ( System.Elaboration_Allocators.
+ Mark_Start_Of_Elaboration;);
+ end if;
+
+ -- Generate assignments to initialize globals
+
Set_String ( Main_Priority := );
Set_Int(Main_Priority);
Set_Char (';');
@@ -996,6 +1008,15 @@
Gen_Elab_Calls;
+ -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
+ -- restriction No_Standard_Allocators_After_Elaboration is active.
+
+ if Cumulative_Restrictions.Set
+(No_Standard_Allocators_After_Elaboration)
+ then
+ WBI ( System.Elaboration_Allocators.Mark_End_Of_Elaboration;);
+ end if;
+
-- From this point, no new dispatching domain can be created.
if Dispatching_Domains_Used then
@@ -2482,10 +2503,23 @@
WBI (with System.Restrictions;);
end if;
+ -- Generate with of Ada.Exceptions if needs library finalization
+
if Needs_Library_Finalization then
WBI (with Ada.Exceptions;);
end if;
+ -- Generate with of System.Elaboration_Allocators if the restriction
+ -- No_Standard_Allocators_After_Elaboration was present.
+
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
+ then
+ WBI (with System.Elaboration_Allocators;);
+ end if;
+
+ -- Generate start of package body
+
WBI ();
WBI (package body Ada_Main is);
[Ada] Enforce style check for all binary operators
Add two missing style checks for token spacing for binary operators when switches -gnatyt, -gnatyy or -gnatyg is used. Preserve previous behavior with debug switch -gnatd.Q Test: $ gcc -c pkg.ads -gnatyt -gnatl -gnatd7 Compiling: pkg.ads 1. package Pkg is 2.One : constant := 1; 3.type Entier is range 0 .. 16-One; | (style) space required 4.AB : constant String := AB; | (style) space required 5. end Pkg; 5 lines: No errors, 2 warnings Invoking gcc -c pkg.ads -gnatyt -gnatd.Q should not report any warning. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Vincent Celier cel...@adacore.com * par-ch4.adb (Simple_Expression): Add missing style check for binary adding operators. (Term): Add missing style check for multiplying operators. Index: debug.adb === --- debug.adb (revision 212725) +++ debug.adb (working copy) @@ -134,7 +134,7 @@ -- d.N Add node to all entities -- d.O Dump internal SCO tables -- d.P Previous (non-optimized) handling of length comparisons - -- d.Q + -- d.Q Previous (incomplete) style check for binary operators -- d.R Restrictions in ali files in positional form -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) Index: par-ch4.adb === --- par-ch4.adb (revision 212656) +++ par-ch4.adb (working copy) @@ -2152,6 +2152,11 @@ exit when Token not in Token_Class_Binary_Addop; Tokptr := Token_Ptr; Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr); + + if Style_Check and then not Debug_Flag_Dot_QQ then + Style.Check_Binary_Operator; + end if; + Scan; -- past operator Set_Left_Opnd (Node2, Node1); Node1 := P_Term; @@ -2406,6 +2411,11 @@ exit when Token not in Token_Class_Mulop; Tokptr := Token_Ptr; Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr); + + if Style_Check and then not Debug_Flag_Dot_QQ then +Style.Check_Binary_Operator; + end if; + Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor);
[Ada] Container Indexing over a derived container type
the container type is a derived type, the value of the inherited aspect is the Reference (or Constant_Reference) operation declared for the parent type. However, Reference is also a primitive operation of the new type, and the inherited operation has a different signature. It is necessary to retrieve the right operation from the list of primitive operations of the derived type. Compiling and executing the following must yield: 2 10 111 1 --- with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Strings.Hash; use Ada.Containers; with Text_IO; use Text_IO; procedure Derived_Container is function Same_Strings (S, T : String) return Boolean is begin return To_Lower (S) = To_Lower (T); end Same_Strings; type Place is record Page : Positive; Line : Positive; Col : Positive; end record; package Places is new Doubly_Linked_Lists (Place); package Indexes is new Indefinite_Hashed_Maps (Key_Type= String, Element_Type= Places.List, Hash= Ada.Strings.Hash, Equivalent_Keys = Same_Strings, = = Places.=); type Text_Map is new Indexes.Map with null record; -- with Variable_Indexing = Reference; -- Without aspect, indexing gives -- container cannot be indexed with Cursor My_Index : Text_Map; My_Place : constant Place := (1, 2, 3); use type Indexes.Cursor; procedure Add_Entry (The_Index : in out Text_Map; Word : String; P : Place) is M_Cursor : Indexes.Cursor; New_List : Places.List := Places.Empty_List; begin M_Cursor := The_Index.Find (Word); if M_Cursor /= Indexes.No_Element then The_Index (M_Cursor).Append (P); else New_List.Append (P); The_Index.Include (Word, New_List); end if; end Add_Entry; begin Add_Entry (The_Index = My_Index, Word = bill, P = My_Place); Add_Entry (The_Index = My_Index, Word = John, P = (10, 10, 10)); Add_Entry (The_Index = My_Index, Word = John, P = (111, 333, 999)); Put_Line (Integer'Image (Integer (My_Index.Length))); for Datum of My_Index loop for Location of Datum loop Put_Line (Integer'Image (Location.Page)); end loop; end loop; end Derived_Container; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Ed Schonberg schonb...@adacore.com * sem_ch4.adb (Try_Container_Indexing): If the container type is a derived type, the value of the inherited aspect is the Reference operation declared for the parent type. However, Reference is also a primitive operation of the new type, and the inherited operation has a different signature. We retrieve the right one from the list of primitive operations of the derived type. Index: sem_ch4.adb === --- sem_ch4.adb (revision 212779) +++ sem_ch4.adb (working copy) @@ -7020,6 +7020,16 @@ else return False; end if; + + -- If the container type is a derived type, the value of the inherited + -- aspect is the Reference operation declared for the parent type. + -- However, Reference is also a primitive operation of the type, and + -- the inherited operation has a different signature. We retrieve the + -- right one from the list of primitive operations of the derived type. + + elsif Is_Derived_Type (Etype (Prefix)) then + Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name)); + Func_Name := New_Occurrence_Of (Func, Loc); end if; Assoc := New_List (Relocate_Node (Prefix));
[Ada] Make sure all rep clauses are removed from tree for -gnatI
Previously all rep clauses were ignored in -gnatI mode, but in two
cases (enumeration rep clauses and record rep clauses), they were
not removed from the tree, causing trouble with ASIS tools. These
two cases are now consistent, and ASIS tools will see none of the
ignored rep clauses (e.g. gnatpp will not list ignored rep clauses).
The following test generates no output if compiled with
gcc -c ignorei.ads -gnatI -gnatG log
grep 35 log
1. package IgnoreI is
2.type R is record
3. X : Integer;
4.end record;
5.for R use record
6. X at 0 range 0 .. 35;
7.end record;
8.type E is (a,b,c);
9.for E use (0,1,35);
10. end IgnoreI;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-18 Robert Dewar de...@adacore.com
* freeze.adb (Check_Address_Clause): Use Kill_Rep_Clause (no
functional change).
* gnat_ugn.texi: Document that -gnatI removes rep clauses from
ASIS trees.
* sem_ch13.adb (Kill_Rep_Clause): New procedure
(Analyze_Attribute_Definition_Clause): Use
Kill_Rep_Clause. This is just a cleanup, no functional effect.
(Analyze_Enumeration_Representation_Clause):
Use Kill_Rep_Clause. This means that enum rep
clauses are now properly removed from -gnatct trees.
(Analyze_Record_Representation_Clause): Same change.
* sem_ch13.ads (Kill_Rep_Clause): New procedure.
Index: gnat_ugn.texi
===
--- gnat_ugn.texi (revision 212782)
+++ gnat_ugn.texi (working copy)
@@ -4091,6 +4091,12 @@
Note that this option should be used only for compiling -- the
code is likely to malfunction at run time.
+Note that when @code{-gnatct} is used to generate trees for input
+into @code{ASIS} tools, these representation clauses are removed
+from the tree. This means that the tool will not see them. For
+example, if you use @command{gnatpp} with @code{-gnatI}, the pretty printed
+output will not include the ignored representation clauses.
+
@item -gnatjnn
@cindex @option{-gnatjnn} (@command{gcc})
Reformat error messages to fit on nn character lines
Index: freeze.adb
===
--- freeze.adb (revision 212737)
+++ freeze.adb (working copy)
@@ -604,8 +604,10 @@
end if;
end;
-Rewrite (Addr, Make_Null_Statement (Sloc (E)));
+-- And now remove the address clause
+Kill_Rep_Clause (Addr);
+
elsif not Error_Posted (Expr)
and then not Needs_Finalization (Typ)
then
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 212782)
+++ sem_ch13.adb(working copy)
@@ -3647,19 +3647,12 @@
Attribute_Machine_Radix |
Attribute_Object_Size|
Attribute_Size |
+ Attribute_Small |
Attribute_Stream_Size|
Attribute_Value_Size =
- Rewrite (N, Make_Null_Statement (Sloc (N)));
+ Kill_Rep_Clause (N);
return;
--- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
-
-when Attribute_Small =
- if Ignore_Rep_Clauses then
- Rewrite (N, Make_Null_Statement (Sloc (N)));
- return;
- end if;
-
-- The following should not be ignored, because in the first place
-- they are reasonably portable, and should not cause problems in
-- compiling code from another target, and also they do affect
@@ -3676,6 +3669,13 @@
Attribute_Write =
null;
+-- We do not do anything here with address clauses, they will be
+-- removed by Freeze later on, but for now, it works better to
+-- keep then in the tree.
+
+when Attribute_Address =
+ null;
+
-- Other cases are errors (attribute cannot be set with
-- definition clause), which will be caught below.
@@ -3830,7 +3830,7 @@
-- Even when ignoring rep clauses we need to indicate that the
-- entity has an address clause and thus it is legal to declare
--- it imported.
+-- it imported. Freeze will get rid of the address clause later.
if Ignore_Rep_Clauses then
if Ekind_In (U_Ent, E_Variable, E_Constant) then
@@ -5365,6 +5365,7 @@
begin
if Ignore_Rep_Clauses then
+ Kill_Rep_Clause (N);
return;
end if;
@@ -5740,6 +5741,7 @@
begin
if Ignore_Rep_Clauses then
+ Kill_Rep_Clause (N);
return;
end if;
@@ -10286,6 +10288,16 @@
end if;
[Ada] Failure to detect illegal parens in static predicate
The rules for static predicates do not allow the type name to be parenthesized. This was not checked, but is now fixed, the following test now gives the error indicated (compiled with -gnatld7 -gnatj55) (it used to compile without errors). 1. package BadParenSP is 2.subtype r is integer with 3. static_predicate = (r) 2; | expression does not have required form for static predicate 4. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Robert Dewar de...@adacore.com * sem_ch13.adb (Is_Type_Ref): Check that type name is not parenthesized. Index: sem_ch13.adb === --- sem_ch13.adb(revision 212797) +++ sem_ch13.adb(working copy) @@ -6247,7 +6247,8 @@ pragma Inline (Is_Type_Ref); -- Returns if True if N is a reference to the type for the predicate in -- the expression (i.e. if it is an identifier whose Chars field matches - -- the Nam given in the call). + -- the Nam given in the call). N must not be parenthesized, if the type + -- name appears in parens, this routine will return False. function Lo_Val (N : Node_Id) return Uint; -- Given static expression or static range from a Static_Predicate list, @@ -6770,7 +6771,9 @@ function Is_Type_Ref (N : Node_Id) return Boolean is begin - return Nkind (N) = N_Identifier and then Chars (N) = Nam; + return Nkind (N) = N_Identifier + and then Chars (N) = Nam + and then Paren_Count (N) = 0; end Is_Type_Ref;
[Ada] Alternate output modes for GNAT.Memory_Dump
Output lines from GNAT.Memory_Dump.Dump can now be prefixed with an offset relative to the start of the dump, or have no prefix at all, instead of showing an absolute address. Test: $ gnatmake -q dump_test $ ./dump_test 00: 4C 6F 72 65 6D 20 69 70 73 75 6D 20 64 6F 6C 6F Lorem ipsum dolo 10: 72 20 73 69 74 20 61 6D 65 74 2C 20 63 6F 6E 73 r sit amet, cons 20: 65 63 74 65 74 75 65 72 20 61 64 69 70 69 73 63 ectetuer adipisc 30: 69 6E 67 20 73 65 64 20 64 69 61 6D 20 6E 6F 6E ing sed diam non 40: 75 6D um with Ada.Text_IO; use Ada.Text_IO; with GNAT.Memory_Dump; use GNAT.Memory_Dump; procedure Dump_Test is S : constant String := Lorem ipsum dolor sit amet, consectetuer adipiscing sed diam nonum; begin Dump (S'Address, S'Length, Offset); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Thomas Quinot qui...@adacore.com * g-memdum.adb, g-memdum.ads (Dump): New parameter Prefix, defaulted to Absolute_Address. Index: g-memdum.adb === --- g-memdum.adb(revision 212640) +++ g-memdum.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2010, AdaCore -- +-- Copyright (C) 2003-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- -- @@ -30,6 +30,7 @@ -- with System; use System; +with System.Img_BIU; use System.Img_BIU; with System.Storage_Elements; use System.Storage_Elements; with GNAT.IO; use GNAT.IO; @@ -43,10 +44,18 @@ -- Dump -- -- - procedure Dump (Addr : System.Address; Count : Natural) is + procedure Dump + (Addr : Address; + Count : Natural; + Prefix : Prefix_Type := Absolute_Address) + is Ctr : Natural := Count; -- Count of bytes left to output + Offset_Buf : String (1 .. Standard'Address_Size / 4 + 4); + Offset_Last : Natural; + -- Buffer for prefix in Offset mode + Adr : Address := Addr; -- Current address @@ -56,14 +65,12 @@ C : Character; -- Character at current storage address - AIL : constant := Address_Image_Length - 4 + 2; - -- Number of chars in initial address + colon + space + AIL : Natural; + -- Number of chars in prefix (including colon and space) - Line_Len : constant Natural := AIL + 3 * 16 + 2 + 16; + Line_Len : Natural; -- Line length for entire line - Line_Buf : String (1 .. Line_Len); - Hex : constant array (0 .. 15) of Character := 0123456789ABCDEF; type Char_Ptr is access all Character; @@ -71,53 +78,89 @@ function To_Char_Ptr is new Ada.Unchecked_Conversion (Address, Char_Ptr); begin - while Ctr /= 0 loop + case Prefix is + when Absolute_Address = +AIL := Address_Image_Length - 4 + 2; + when Offset = +Offset_Last := Offset_Buf'First - 1; +Set_Image_Based_Integer (Ctr, 16, 0, Offset_Buf, Offset_Last); +AIL := Offset_Last - 4 + 2; + when None = +AIL := 0; + end case; + Line_Len := AIL + 3 * 16 + 2 + 16; - -- Start of line processing + declare + Line_Buf : String (1 .. Line_Len); + begin + while Ctr /= 0 loop - if N = 0 then -declare - S : constant String := Image (Adr); -begin - Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) : ; +-- Start of line processing + +if N = 0 then + case Prefix is + when Absolute_Address = + declare +S : constant String := Image (Adr); + begin +Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) : ; + end; + + when Offset = + declare +Last : Natural := 0; +Len : Natural; + begin +Set_Image_Based_Integer + (Count - Ctr, 16, 0, Offset_Buf, Last); +Len := Last - 4; + +Line_Buf (1 .. AIL - Len - 2) := (others = '0'); +Line_Buf (AIL - Len - 1 .. AIL - 2) := +
[Ada] Allows Wide_String output on Windows console
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-18 Pascal Obry o...@adacore.com
* s-crtl.ads, i-cstrea.ads (fputwc): New routine.
* a-witeio.adb (Put): On platforms where there is translation
done by the OS output the raw text.
(New_Line): Use Put above to properly handle the LM wide characters.
Index: sysdep.c
===
--- sysdep.c(revision 212717)
+++ sysdep.c(working copy)
@@ -104,11 +104,12 @@
file positioning function, unless the input operation encounters
end-of-file.
- The other target dependent declarations here are for the two functions
- __gnat_set_binary_mode and __gnat_set_text_mode:
+ The other target dependent declarations here are for the three functions
+ __gnat_set_binary_mode, __gnat_set_text_mode and __gnat_set_wide_text_mode:
void __gnat_set_binary_mode (int handle);
void __gnat_set_text_mode (int handle);
+ void __gnat_set_wide_text_mode (int handle);
These functions have no effect in Unix (or similar systems where there is
no distinction between binary and text files), but in DOS (and similar
@@ -150,6 +151,12 @@
WIN_SETMODE (handle, O_TEXT);
}
+void
+__gnat_set_wide_text_mode (int handle)
+{
+ WIN_SETMODE (handle, _O_U16TEXT);
+}
+
#ifdef __CYGWIN__
char *
@@ -245,6 +252,12 @@
__gnat_set_text_mode (int handle ATTRIBUTE_UNUSED)
{
}
+
+void
+__gnat_set_wide_text_mode (int handle ATTRIBUTE_UNUSED)
+{
+}
+
char *
__gnat_ttyname (int filedes)
{
Index: s-crtl.ads
===
--- s-crtl.ads (revision 212640)
+++ s-crtl.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -122,6 +122,9 @@
function fputc (C : int; stream : FILEs) return int;
pragma Import (C, fputc, fputc);
+ function fputwc (C : int; stream : FILEs) return int;
+ pragma Import (C, fputwc, fputwc);
+
function fputs (Strng : chars; Stream : FILEs) return int;
pragma Import (C, fputs, fputs);
Index: i-cstrea.ads
===
--- i-cstrea.ads(revision 212640)
+++ i-cstrea.ads(working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
@@ -119,6 +119,9 @@
function fputc (C : int; stream : FILEs) return int
renames System.CRTL.fputc;
+ function fputwc (C : int; stream : FILEs) return int
+ renames System.CRTL.fputwc;
+
function fputs (Strng : chars; Stream : FILEs) return int
renames System.CRTL.fputs;
@@ -223,8 +226,9 @@
-- versa. These functions have no effect if text_translation_required is
-- false (i.e. in normal unix mode). Use fileno to get a stream handle.
- procedure set_binary_mode (handle : int);
- procedure set_text_mode (handle : int);
+ procedure set_binary_mode(handle : int);
+ procedure set_text_mode (handle : int);
+ procedure set_wide_text_mode (handle : int);
-- Full Path Name support --
@@ -256,6 +260,7 @@
pragma Import (C, set_binary_mode, __gnat_set_binary_mode);
pragma Import (C, set_text_mode, __gnat_set_text_mode);
+ pragma Import (C, set_wide_text_mode, __gnat_set_wide_text_mode);
pragma Import (C, max_path_len, __gnat_max_path_len);
pragma Import (C, full_name, __gnat_full_name);
Index: a-witeio.adb
===
--- a-witeio.adb(revision 212640)
+++ a-witeio.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
--
[Ada] Primitive operations of incomplete types
In Ada 2012, the formals of a subprogram can be incomplete types, and the subprogram is a primitive operation of the type. If the type is subsequently derived, it inherits the operation, and it can be explicitly overridden. Executing main.adb must yield: 1 2 --- with Prim_Test; use Prim_Test; procedure Main is One : T := (Val = 1); Two : T := (Val = 2); begin Q (One); Q (Two); end; --: package Prim_Test is type T; procedure P (V : T); procedure Q (It : T); type T is record Val : Integer; end record; type T2 is new T; overriding procedure P (V : T2); end Prim_Test; --- with Text_IO; use Text_IO; package body Prim_Test is procedure P (V : T) is begin null; end P; procedure Q (It : T) is begin Put_Line (Integer'Image (It.Val)); end; overriding procedure P (V : T2) is begin null; end P; end Prim_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Ed Schonberg schonb...@adacore.com * sinfo.ads, sinfo.adb (Incomplete_View): New semantic attribute of full type declaration, denotes previous declaration for incomplete view of the type. * sem_ch3.adb (Analyze_Full_Type_Declaration): Set Incomplete_View of declaration if one is present. (Replace_Type): When constructing the signature of an inherited operation, handle properly the case where the operation has a formal whose type is an incomplete view. * sem_util.adb (Collect_Primitive_Operations): Handle properly the case of an operation declared after an incomplete declaration for a type T and before the full declaration of T. Index: sem_ch3.adb === --- sem_ch3.adb (revision 212797) +++ sem_ch3.adb (working copy) @@ -2464,6 +2464,8 @@ Prev := Find_Type_Name (N); -- The full view, if present, now points to the current type + -- If there is an incomplete partial view, set a link to it, to + -- simplify the retrieval of primitive operations of the type. -- Ada 2005 (AI-50217): If the type was previously decorated when -- imported through a LIMITED WITH clause, it appears as incomplete @@ -2472,6 +2474,7 @@ if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) then T := Full_View (Prev); + Set_Incomplete_View (N, Parent (Prev)); else T := Prev; end if; @@ -13537,6 +13540,7 @@ -- procedure Replace_Type (Id, New_Id : Entity_Id) is + Id_Type : constant Entity_Id := Etype (Id); Acc_Type : Entity_Id; Par : constant Node_Id := Parent (Derived_Type); @@ -13547,9 +13551,9 @@ -- be out of the proper scope for Gigi, so we insert a reference to -- it after the derivation. - if Ekind (Etype (Id)) = E_Anonymous_Access_Type then + if Ekind (Id_Type) = E_Anonymous_Access_Type then declare - Desig_Typ : Entity_Id := Designated_Type (Etype (Id)); + Desig_Typ : Entity_Id := Designated_Type (Id_Type); begin if Ekind (Desig_Typ) = E_Record_Type_With_Private @@ -13567,7 +13571,7 @@ or else (Is_Interface (Desig_Typ) and then not Is_Class_Wide_Type (Desig_Typ)) then - Acc_Type := New_Copy (Etype (Id)); + Acc_Type := New_Copy (Id_Type); Set_Etype (Acc_Type, Acc_Type); Set_Scope (Acc_Type, New_Subp); @@ -13599,16 +13603,23 @@ Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); else - Set_Etype (New_Id, Etype (Id)); + Set_Etype (New_Id, Id_Type); end if; end; - elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) + -- In Ada2012, a formal may have an incomplete type but the type + -- derivation that inherits the primitive follows the full view. + + elsif Base_Type (Id_Type) = Base_Type (Parent_Type) or else - (Ekind (Etype (Id)) = E_Record_Type_With_Private - and then Present (Full_View (Etype (Id))) + (Ekind (Id_Type) = E_Record_Type_With_Private + and then Present (Full_View (Id_Type)) and then - Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type)) + Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) + or else + (Ada_Version = Ada_2012 +and then Ekind (Id_Type) = E_Incomplete_Type +and then Full_View (Id_Type) = Parent_Type) then -- Constraint checks on formals are generated during expansion, -- based on the signature of the original
[Ada] Reorganize handling of predicates
This reorganizes the handling of predicates, in preparation for proper implementation of real predicates. Several minor errors are corrected and we properly reject improper static real predicates. Static string predicates are now always rejected, in line with latest ARG thinking. The following shows how far we have got. Quite a few minor errors are fixed in recognizing predicate-static expressions. Still to be done is actual compile-time testing of real static predicates, and also noting that constants for which a predicate fails should not be considered as static. 1. package TestSP is 2.subtype F1 is Float with -- OK 3. Static_Predicate = F1 0.0 and 4.7 F1; 4.subtype F2 is Float with -- ERROR 5. Static_Predicate = (F2 + 1.0) 0.0 and 4.7 F2; | expression is not predicate-static (RM 4.3.2(16-22)) 6.subtype F3 is Float with -- OK 7. Dynamic_Predicate = (F3 + 1.0) 0.0 and 4.7 F3; 8.subtype F4 is Float with -- OK 9. Predicate = (F4 + 1.0) 0.0 and 4.7 F4; 10. 11.subtype S1 is String with -- OK 12. Static_Predicate = S1 ABC and then DEF = S1; 13.subtype S2 is String with -- ERROR 14. Static_Predicate = S2'First = 1 and then S2(1) = 'A'; | static predicate not allowed for non-scalar type S2 15.subtype S3 is String with -- OK 16. Dynamic_Predicate = S3'First = 1 and then S3(1) = 'A'; 17.subtype S4 is String with -- OK 18. Predicate = S4'First = 1 and then S4(1) = 'A'; 19. 20.subtype I1 is Integer with -- OK 21. Static_Predicate = I1 0 and 4 I1; 22.subtype I2 is Integer with -- ERROR 23. Static_Predicate = (I2 + 1) 0 and 4 I2; | expression is not predicate-static (RM 4.3.2(16-22)) 24.subtype I3 is Integer with -- OK 25. Dynamic_Predicate = (I3 + 1) 0 and 4 I3; 26.subtype I4 is Integer with -- OK 27. Predicate = (I4 + 1) 0 and 4 I4; 28.subtype I5 is Integer with -- ERROR (not caught before) 29. Static_Predicate = Boolean'(I5 0); | expression is not predicate-static (RM 4.3.2(16-22)) 30. 31.XF1 : constant F1 := 10.0; | warning: real predicate not applied 32.XF2 : constant F1 := 3.0; | warning: real predicate not applied 33.XF3 : constant := XF1; -- ERROR (not caught yet) 34. 35.XI1 : constant I1 := 10; | warning: static expression fails predicate check on I1 36.XI2 : constant I1 := 3; 37.XI3 : constant := XI1; -- ERROR (not caught yet) 38. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Robert Dewar de...@adacore.com * einfo.adb (Has_Static_Predicate): New function. (Set_Has_Static_Predicate): New procedure. * einfo.ads (Has_Static_Predicate): New flag. * sem_ch13.adb (Is_Predicate_Static): New function (Build_Predicate_Functions): Use Is_Predicate_Static to reorganize (Add_Call): Minor change in Sloc of generated expression (Add_Predicates): Remove setting of Static_Pred, no longer used. * sem_ch4.adb (Has_Static_Predicate): Removed this function, replace by use of the entity flag Has_Static_Predicate_Aspect. * sem_eval.adb (Eval_Static_Predicate_Check): Check real case and issue warning that predicate is not checked for now. * sem_eval.ads (Eval_Static_Predicate_Check): Fix comments in spec. * sem_util.adb (Check_Expression_Against_Static_Predicate): Carry out check for any case where there is a static predicate, and output appropriate message. * sinfo.ads: Minor comment corrections. Index: sinfo.ads === --- sinfo.ads (revision 212802) +++ sinfo.ads (working copy) @@ -4022,13 +4022,13 @@ -- to deal with, and diagnose a simple expression other than a name for -- the right operand. This simplifies error recovery in the parser. - -- The Alternatives field below is present only if there is more - -- than one Membership_Choice present (which is legitimate only in - -- Ada 2012 mode) in which case Right_Opnd is Empty, and Alternatives - -- contains the list of choices. In the tree passed to the back end, - -- Alternatives is always No_List, and Right_Opnd is set (i.e. the - -- expansion circuitry expands out the complex set membership case - -- using simple membership operations). + -- The Alternatives field below is present only if there is more than + -- one Membership_Choice present (which is legitimate only in
[Ada] Constants are non-static if they fail a predicate check
If a constant is defined with a static expression, and the expression statically fails a static predicate, then the constant is not considered as being static, as shown by this updated example (see last few lines) 1. package TestSP is 2.subtype F1 is Float with -- OK 3. Static_Predicate = F1 0.0 and 4.7 F1; 4.subtype F2 is Float with -- ERROR 5. Static_Predicate = (F2 + 1.0) 0.0 and 4.7 F2; | expression is not predicate-static (RM 4.3.2(16-22)) 6.subtype F3 is Float with -- OK 7. Dynamic_Predicate = (F3 + 1.0) 0.0 and 4.7 F3; 8.subtype F4 is Float with -- OK 9. Predicate = (F4 + 1.0) 0.0 and 4.7 F4; 10. 11.subtype S1 is String with -- OK 12. Static_Predicate = S1 ABC and then DEF = S1; 13.subtype S2 is String with -- ERROR 14. Static_Predicate = S2'First = 1 and then S2(1) = 'A'; | static predicate not allowed for non-scalar type S2 15.subtype S3 is String with -- OK 16. Dynamic_Predicate = S3'First = 1 and then S3(1) = 'A'; 17.subtype S4 is String with -- OK 18. Predicate = S4'First = 1 and then S4(1) = 'A'; 19. 20.subtype I1 is Integer with -- OK 21. Static_Predicate = I1 0 and 4 I1; 22.subtype I2 is Integer with -- ERROR 23. Static_Predicate = (I2 + 1) 0 and 4 I2; | expression is not predicate-static (RM 4.3.2(16-22)) 24.subtype I3 is Integer with -- OK 25. Dynamic_Predicate = (I3 + 1) 0 and 4 I3; 26.subtype I4 is Integer with -- OK 27. Predicate = (I4 + 1) 0 and 4 I4; 28.subtype I5 is Integer with -- ERROR (not caught before) 29. Static_Predicate = Boolean'(I5 0); | expression is not predicate-static (RM 4.3.2(16-22)) 30. 31.XF1 : constant F1 := 10.0; -- WARN (not yet) | warning: real predicate not applied 32.XF2 : constant F1 := 3.0; -- OK | warning: real predicate not applied 33.XF3 : constant := XF1; -- ERROR (not caught yet) 34.XF4 : constant := XF2; -- OK 35. 36.XI1 : constant I1 := 10; -- WARN | warning: static expression fails predicate check on I1 warning: expression is no longer considered static 37.XI2 : constant I1 := 3; -- OK 38.XI3 : constant := XI1; -- ERROR | non-static expression used in number declaration XI1 is not a static constant (RM 4.9(5)) 39.XI4 : constant := XI2; -- OK 40. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Robert Dewar de...@adacore.com * sem_util.adb (Check_Expression_Against_Static_Predicate): Mark expression as non-static if it fails static predicate check, and issue additional warning. Index: sem_util.adb === --- sem_util.adb(revision 212804) +++ sem_util.adb(working copy) @@ -1718,6 +1718,17 @@ else Error_Msg_NE (??static expression fails predicate check on , Expr, Typ); + +-- We now reset the static expression indication on the expression +-- since it is no longer static if it fails a predicate test. We +-- do not do this if the predicate was officially dynamic, since +-- dynamic predicates don't affect legality in this manner. + +if not Has_Dynamic_Predicate_Aspect (Typ) then + Error_Msg_N + (\??expression is no longer considered static, Expr); + Set_Is_Static_Expression (Expr, False); +end if; end if; end if; end Check_Expression_Against_Static_Predicate;
[Ada] Error handling consistency for named associations
An error occurring in a subexpression that is part of some construct in general suppresses the reporting of further errors on the same construct, to avoid noisy cascaded messages. This patch ensures that this is also the case when named associations are present. The following test case must be rejected with the indicated errors only (note no additional message in the case where a named discriminant association is used). $ gcc -c bogus_constraint.ads bogus_constraint.ads:9:21: Cst1 is not visible bogus_constraint.ads:9:21: non-visible declaration at line 3 bogus_constraint.ads:10:30: Cst2 is not visible bogus_constraint.ads:10:30: non-visible declaration at line 4 package Bogus_Constraint is package P is Cst1 : constant Integer := 1; Cst2 : constant Integer := 2; end P; type R (Start, Endx : Integer) is null record; subtype R1 is R (Cst1); subtype R2 is R (Start = Cst2); end Bogus_Constraint; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Thomas Quinot qui...@adacore.com * errout.adb (Set_Error_Posted): When propagating flag to an enclosing named association, also propagate to the parent of that node, so that named and positional associations are treated consistently. Index: errout.adb === --- errout.adb (revision 213154) +++ errout.adb (working copy) @@ -156,11 +156,12 @@ -- variables Msg_Buffer are set on return Msglen. procedure Set_Posted (N : Node_Id); - -- Sets the Error_Posted flag on the given node, and all its parents - -- that are subexpressions and then on the parent non-subexpression - -- construct that contains the original expression (this reduces the - -- number of cascaded messages). Note that this call only has an effect - -- for a serious error. For a non-serious error, it has no effect. + -- Sets the Error_Posted flag on the given node, and all its parents that + -- are subexpressions and then on the parent non-subexpression construct + -- that contains the original expression. If that parent is a named + -- association, the flag is further propagated to its parent. This is done + -- in order to guard against cascaded errors. Note that this call has an + -- effect for a serious error only. procedure Set_Qualification (N : Nat; E : Entity_Id); -- Outputs up to N levels of qualification for the given entity. For @@ -3007,6 +3008,16 @@ exit when Nkind (P) not in N_Subexpr; end loop; + if Nkind_In (P, + N_Pragma_Argument_Association, + N_Component_Association, + N_Discriminant_Association, + N_Generic_Association, + N_Parameter_Association) + then +Set_Error_Posted (Parent (P)); + end if; + -- A special check, if we just posted an error on an attribute -- definition clause, then also set the entity involved as posted. -- For example, this stops complaining about the alignment after
[Ada] Interface conversions and limited_with clauses.
In conversions of prefixed calls involving interfaces, the expression in the conversion may have a limited view of a type obtained transitively through several contexts. Use the non-limited view if available, to enable subsequent interface membership tests. The following must compile quietly: gcc -c rich_graph.adb --- with Edge; with Vertex; with Graph; package Rich_Graph is type Object is new Graph.Object with private; type Class_Ref is access all Object'Class; overriding function Other_End (G : in Object; E : in Edge.Class_Ref; V : in Vertex.Class_Ref) return Vertex.Class_Ref; private type Object is new Graph.Object with null record; end Rich_Graph; --- with Rich_Edge; with Rich_Vertex; package body Rich_Graph is overriding function Other_End (G : in Object; E : in Edge.Class_Ref; V : in Vertex.Class_Ref) return Vertex.Class_Ref is Rich_E : Rich_Edge.Class_Ref; Rich_V : Rich_Vertex.Class_Ref; begin Rich_E := Rich_Edge.Class_Ref (E); Rich_V := Rich_Vertex.Class_Ref (V); return Vertex.Class_Ref (Rich_E.Other_End (Rich_V)); end Other_End; end Rich_Graph; --- package Edge is type Object is limited interface; type Class_Ref is access all Object'Class; end Edge; --- package Vertex is type Object is limited interface; type Class_Ref is access all Object'Class; end Vertex; --- with Vertex; with Edge; package Graph is type Object is limited interface; type Class_Ref is access all Object'Class; function Other_End (Graph : in Object; E : in Edge.Class_Ref; V : in Vertex.Class_Ref) return Vertex.Class_Ref is abstract; end Graph; --- with Edge; limited with Rich_Vertex; package Rich_Edge is type Object is limited interface and Edge.Object; type Class_Ref is access all Object'Class; function Other_End (E : in Object; V : access Rich_Vertex.Object'Class) return Rich_Vertex.Class_Ref is abstract; end Rich_Edge; --- with Vertex; package Rich_Vertex is type Object is limited interface and Vertex.Object; type Class_Ref is access all Object'Class; end Rich_Vertex; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Ed Schonberg schonb...@adacore.com * sem_res.adb (Resolve_Type_Conversion): If the type of the expression is a limited view, use the non-limited view when available. Index: sem_res.adb === --- sem_res.adb (revision 213154) +++ sem_res.adb (working copy) @@ -10193,6 +10193,17 @@ Target : Entity_Id := Target_Typ; begin +-- If the type of the operand is a limited view, use the non- +-- limited view when available. + +if From_Limited_With (Opnd) + and then Ekind (Opnd) in Incomplete_Kind + and then Present (Non_Limited_View (Opnd)) +then + Opnd := Non_Limited_View (Opnd); + Set_Etype (Expression (N), Opnd); +end if; + if Is_Access_Type (Opnd) then Opnd := Designated_Type (Opnd); end if;
[Ada] Undefined symbols when building GPS
This patch ensures that abort-related expansion generates the same amount of internal entities when aborts are allowed or are being suppressed by pragma Restriction (No_Abort_Statements). Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Hristian Kirtchev kirtc...@adacore.com * exp_ch3.adb (Default_Initialize_Object): Add new variables Abrt_Blk and Dummy. Generate a dummy temporary when aborts are not allowed to ensure the symmetrical generation of symbols. * exp_ch7.adb (Build_Object_Declarations): Remove variables A_Expr and E_Decl. Add new variables Decl and Dummy. Generate a dummy temporary when aborts are not allowed to ensure symmertrical generation of symbols. * exp_intr.adb (Expand_Unc_Deallocation): Add new variable Dummy. Generate a dummy temporary when aborts are not allowed to ensure symmertrical generation of symbols. Index: exp_ch7.adb === --- exp_ch7.adb (revision 213156) +++ exp_ch7.adb (working copy) @@ -3134,9 +3134,13 @@ Loc : Source_Ptr; For_Package : Boolean := False) is - A_Expr : Node_Id; - E_Decl : Node_Id; + Decl : Node_Id; + Dummy : Entity_Id; + pragma Unreferenced (Dummy); + -- This variable captures an unused dummy internal entity, see the + -- comment associated with its use. + begin pragma Assert (Decls /= No_List); @@ -3164,56 +3168,61 @@ -- does not include routine Raise_From_Controlled_Operation which is the -- the sole user of flag Abort. - -- This is not needed for library-level finalizers as they are called - -- by the environment task and cannot be aborted. + -- This is not needed for library-level finalizers as they are called by + -- the environment task and cannot be aborted. - if Abort_Allowed -and then VM_Target = No_VM -and then not For_Package - then - Data.Abort_Id := Make_Temporary (Loc, 'A'); + if VM_Target = No_VM and then not For_Package then + if Abort_Allowed then +Data.Abort_Id := Make_Temporary (Loc, 'A'); - A_Expr := New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc); +-- Generate: +--Abort_Id : constant Boolean := A_Expr; - -- Generate: +Append_To (Decls, + Make_Object_Declaration (Loc, +Defining_Identifier = Data.Abort_Id, +Constant_Present= True, +Object_Definition = + New_Occurrence_Of (Standard_Boolean, Loc), +Expression = + New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc))); - --Abort_Id : constant Boolean := A_Expr; + -- Abort is not required - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier = Data.Abort_Id, - Constant_Present= True, - Object_Definition = New_Occurrence_Of (Standard_Boolean, Loc), - Expression = A_Expr)); + else +-- Generate a dummy entity to ensure that the internal symbols are +-- in sync when a unit is compiled with and without aborts. +Dummy := Make_Temporary (Loc, 'A'); +Data.Abort_Id := Empty; + end if; + + -- .NET/JVM or library-level finalizers + else - -- No abort, .NET/JVM or library-level finalizers - - Data.Abort_Id := Empty; + Data.Abort_Id := Empty; end if; if Exception_Extra_Info then - Data.E_Id := Make_Temporary (Loc, 'E'); + Data.E_Id := Make_Temporary (Loc, 'E'); -- Generate: - --E_Id : Exception_Occurrence; - E_Decl := + Decl := Make_Object_Declaration (Loc, Defining_Identifier = Data.E_Id, Object_Definition = New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)); - Set_No_Initialization (E_Decl); + Set_No_Initialization (Decl); - Append_To (Decls, E_Decl); + Append_To (Decls, Decl); else - Data.E_Id := Empty; + Data.E_Id := Empty; end if; -- Generate: - --Raised_Id : Boolean := False; Append_To (Decls, Index: exp_intr.adb === --- exp_intr.adb(revision 213156) +++ exp_intr.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +--
[Ada] Missing finalization of a transient class-wide function result
This patch corrects the transient object machinery to disregard aliasing when the associated context is a Boolean expression with actions. This is because the Boolean result is always known after the action list has been evaluated, therefore the transient objects must be finalized at that point. -- 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-29 Hristian Kirtchev kirtc...@adacore.com * exp_ch4.adb (Process_Transient_Object): Remove constant In_Cond_Expr, use its initialization expression in place. * 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_util.adb (Is_Aliased): 'Reference-d or renamed transient objects are not considered aliased when the related context is a Boolean 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. Index: exp_ch4.adb === --- exp_ch4.adb (revision 213156) +++ exp_ch4.adb (working copy) @@ -12616,9 +12616,6 @@ -- If False, call to finalizer includes a test of whether the hook -- pointer is null. - In_Cond_Expr : constant Boolean := - Within_Case_Or_If_Expression (Rel_Node); - begin -- Step 0: determine where to attach finalization actions in the tree @@ -12636,10 +12633,10 @@ -- conditional expression. Finalize_Always := -not (In_Cond_Expr - or else -Nkind_In (Original_Node (Rel_Node), N_Case_Expression, -N_If_Expression)); + not Within_Case_Or_If_Expression (Rel_Node) + and then not Nkind_In +(Original_Node (Rel_Node), N_Case_Expression, + N_If_Expression); declare Loc : constant Source_Ptr := Sloc (Rel_Node); Index: exp_ch7.adb === --- exp_ch7.adb (revision 213157) +++ exp_ch7.adb (working copy) @@ -1817,9 +1817,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 - and then Is_Finalizable_Transient -(Status_Flag_Or_Transient_Decl (Obj_Id), Decl) + N_Object_Declaration then Processing_Actions (Has_No_Init = True); Index: exp_util.adb === --- exp_util.adb(revision 213156) +++ exp_util.adb(working copy) @@ -3435,9 +3435,8 @@ or else Etype (Assoc_Node) /= Standard_Void_Type) and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement and then
[Ada] New pragma Unevaluated_Use_Of_Old
A new pragma Unevaluated_Use_Of_Old (Error | Warn | Allow) is implemented which controls the processing of attributes Old and Loop_Entry. If either of these attributes is used in a potentially unevaluated expression e.g. the then or else parts of an if expression), then normally this usage is considered illegal if the prefix of the attribute is other than an entity name. The language requires this behavior for Old, and GNAT copies the same rule for Loop_Entry. Although the rule avoids this possibility, it is sometimes too restrictive. The pragma Unevaluated_Use_Of_Old can be used to modify this behavior. If the argument is ERROR, then an error is given (this is the default RM behavior). If the argument is WARN then the usage is allowed as legal but with a warning that an exception might be raised. If the argument is ALLOW then the usage is allowed as legal without generating a warning. This pragma may appear as a configuration pragma, or in a declarative part or package specification. In the latter case it applies to uses up to the end of the corresponding statement sequence or sequence of package declarations. The following is compiled with -gnatc -gnatwW -gnatld7 -gnatj60 1. package UnevalOld is 2.K : Character; 3.procedure U (A : String; C : Boolean) -- ERROR 4. with Post = (if C then A(1)'Old = K else True); | prefix of attribute Old that is potentially unevaluated must denote an entity 5.procedure V (A : String; C : Boolean) 6. with Post = A(1)'Old = K; 7. 8.package U1 is 9. pragma Unevaluated_Use_Of_Old (Warn); -- WARNING 10. procedure P1 (A : String; C : Boolean) 11. with Post = (if C then A(1)'Old = K else True); | warning: prefix of attribute Old appears in potentially unevaluated context, exception may be raised 12.end U1; 13. 14.package U2 is 15. pragma Unevaluated_Use_Of_Old (Allow); -- OK 16. procedure P2 (A : String; C : Boolean) 17. with Post = (if C then A(1)'Old = K else True); 18.end U2; 19. end; If the same compilation is carried out with a gnat.adc file that contains the pragma: pragma Unevaluated_Use_Of_Old (Allow); Then the output omits the first error: 1. package UnevalOld is 2.K : Character; 3.procedure U (A : String; C : Boolean) -- ERROR 4. with Post = (if C then A(1)'Old = K else True); 5.procedure V (A : String; C : Boolean) 6. with Post = A(1)'Old = K; 7. 8.package U1 is 9. pragma Unevaluated_Use_Of_Old (Warn); -- WARNING 10. procedure P1 (A : String; C : Boolean) 11. with Post = (if C then A(1)'Old = K else True); | warning: prefix of attribute Old appears in potentially unevaluated context, exception may be raised 12.end U1; 13. 14.package U2 is 15. pragma Unevaluated_Use_Of_Old (Allow); -- OK 16. procedure P2 (A : String; C : Boolean) 17. with Post = (if C then A(1)'Old = K else True); 18.end U2; 19. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar de...@adacore.com * gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old. * opt.adb: Handle Uneval_Old. * opt.ads (Uneval_Old, Uneval_Old_Config): New variables. * par-prag.adb: Add dummy entry for pragma Unevaluated_Use_Of_Old. * sem.ads (Save_Uneval_Old): New field in Scope_Stack_Entry. * sem_attr.adb (Uneval_Old_Msg): New procedure. * sem_ch8.adb (Push_Scope): Save Uneval_Old. (Pop_Scope): Restore Uneval_Old. * sem_prag.adb (Analyze_Pragma, case Unevaluated_Use_Of_Old): Implemented. * snames.ads-tmpl: Add entries for pragma Unevaluated_Use_Of_Old Add entries for Name_Warn, Name_Allow. Index: gnat_rm.texi === --- gnat_rm.texi(revision 213156) +++ gnat_rm.texi(working copy) @@ -270,6 +270,7 @@ * Pragma Type_Invariant:: * Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: +* Pragma Unevaluated_Use_Of_Old:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: @@ -1119,6 +1120,7 @@ * Pragma Type_Invariant:: * Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: +* Pragma Unevaluated_Use_Of_Old:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: @@ -7242,6 +7244,59 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full details, consult the Ada 2012 Reference Manual, section B.3.3. +@node Pragma Unevaluated_Use_Of_Old +@unnumberedsec Pragma Unevaluated_Use_Of_Old +@cindex
[Ada] Cleanup handling of discrete static predicates
This is just an internal cleanup, involving some name changes and slightly cleaned up testing of flags etc. This is part of the preparation for implementing static real predicates. No functional effect. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar de...@adacore.com * sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb, einfo.ads, sem_util.adb, sem_attr.adb, sem_case.adb, sem_eval.adb, sem_eval.ads, sem_ch13.adb: General cleanup of static predicate handling. Change name of Discrete_Predicate to Discrete_Static_Predicate, and replace testing of the presence of this field by testing the flag Has_Static_Expression. Index: sem_aggr.adb === --- sem_aggr.adb(revision 213159) +++ sem_aggr.adb(working copy) @@ -1721,11 +1721,11 @@ -- original choice with the list of individual values -- covered by the predicate. -if Present (Static_Predicate (E)) then +if Present (Static_Discrete_Predicate (E)) then Delete_Choice := True; New_Cs := New_List; - P := First (Static_Predicate (E)); + P := First (Static_Discrete_Predicate (E)); while Present (P) loop C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); Index: exp_ch5.adb === --- exp_ch5.adb (revision 213159) +++ exp_ch5.adb (working copy) @@ -3977,7 +3977,7 @@ LPS : constant Node_Id:= Loop_Parameter_Specification (Isc); Loop_Id : constant Entity_Id := Defining_Identifier (LPS); Ltype : constant Entity_Id := Etype (Loop_Id); - Stat: constant List_Id:= Static_Predicate (Ltype); + Stat: constant List_Id:= Static_Discrete_Predicate (Ltype); Stmts : constant List_Id:= Statements (N); begin Index: sem_ch5.adb === --- sem_ch5.adb (revision 213159) +++ sem_ch5.adb (working copy) @@ -2480,8 +2480,8 @@ -- function only, look for a dynamic predicate aspect as well. if Is_Discrete_Type (Entity (DS)) - and then Present (Predicate_Function (Entity (DS))) - and then (No (Static_Predicate (Entity (DS))) + and then Has_Predicates (Entity (DS)) + and then (not Has_Static_Predicate (Entity (DS)) or else Has_Dynamic_Predicate_Aspect (Entity (DS))) then Bad_Predicated_Subtype_Use Index: exp_util.adb === --- exp_util.adb(revision 213158) +++ exp_util.adb(working copy) @@ -1980,7 +1980,7 @@ -- if the list is empty, corresponding to a False predicate, then -- no choices are inserted. -P := First (Static_Predicate (Entity (Choice))); +P := First (Static_Discrete_Predicate (Entity (Choice))); while Present (P) loop -- If low bound and high bounds are equal, copy simple choice Index: einfo.adb === --- einfo.adb (revision 213160) +++ einfo.adb (working copy) @@ -222,7 +222,7 @@ --DT_Offset_To_Top_Func Node25 --PPC_Wrapper Node25 --Related_Array_ObjectNode25 - --Static_PredicateList25 + --Static_Discrete_Predicate List25 --Task_Body_Procedure Node25 --Dispatch_Table_Wrappers Elist26 @@ -2971,11 +2971,11 @@ return Node19 (Id); end Spec_Entity; - function Static_Predicate (Id : E) return S is + function Static_Discrete_Predicate (Id : E) return S is begin pragma Assert (Is_Discrete_Type (Id)); return List25 (Id); - end Static_Predicate; + end Static_Discrete_Predicate; function Status_Flag_Or_Transient_Decl (Id : E) return N is begin @@ -5761,11 +5761,11 @@ Set_Node19 (Id, V); end Set_Spec_Entity; - procedure Set_Static_Predicate (Id : E; V : S) is + procedure Set_Static_Discrete_Predicate (Id : E; V : S) is begin pragma Assert (Is_Discrete_Type (Id) and then Has_Predicates (Id)); Set_List25 (Id, V); - end Set_Static_Predicate; + end Set_Static_Discrete_Predicate; procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is begin @@ -9404,7 +9404,7 @@ E_Modular_Integer_Type | E_Modular_Integer_Subtype| E_Signed_Integer_Subtype = -Write_Str
[Ada] Implement static predicates for string/real types
This implements static predicates for string and real types, as defined in the RM. There is one exception, which is that the RM allows X ABC as being predicate static, but since ABC ABA is not static, that's peculiar, so we assume that this is a mistake in the RM, and that string comparisons should not be permitted as predicate-static. The following test program shows various uses of static predicates of all types with a range of legality tests and tests for compile time evaluation of static predicates. 1. package TestSP is 2.subtype F1 is Float with -- OK 3.Static_Predicate = F1 0.0 and 4.7 F1; 4. 5.subtype F1a is F1 with -- OK 6. Static_Predicate = F1a 2.4; 7. 8.subtype F2 is Float with -- ERROR 9. Static_Predicate = (F2 + 1.0) 0.0 and 4.7 F2; | expression is not predicate-static (RM 4.3.2(16-22)) 10.subtype F3 is Float with -- OK 11. Dynamic_Predicate = (F3 + 1.0) 0.0 and 4.7 F3; 12.subtype F4 is Float with -- OK 13. Predicate = (F4 + 1.0) 0.0 and 4.7 F4; 14. 15.subtype S0 is String with -- ERROR 16. Static_Predicate = S0 ABC and then DEF = S0; | expression is not predicate-static (RM 4.3.2(16-22)) 17.subtype S1 is String with -- OK 18. Static_Predicate = S1 in ABC | DEF; 19. 20.subtype S2 is String with -- ERROR 21. Static_Predicate = S2'First = 1 and then S2(1) = 'A'; | expression is not predicate-static (RM 4.3.2(16-22)) 22.subtype S3 is String with -- OK 23. Dynamic_Predicate = S3'First = 1 and then S3(1) = 'A'; 24.subtype S4 is String with -- OK 25. Predicate = S4'First = 1 and then S4(1) = 'A'; 26.subtype S5 is String with -- OK 27. Predicate = S5 in ABC | DEF; 28.subtype S6 is String with -- OK 29. Dynamic_Predicate = S6 in ABC | DEF; 30. 31.subtype I1 is Integer with -- OK 32. Static_Predicate = I1 0 and 4 I1; 33.subtype I1a is I1 with -- OK 34. Static_Predicate = I1a 2; 35. 36.subtype I2 is Integer with -- ERROR 37. Static_Predicate = (I2 + 1) 0 and 4 I2; | expression is not predicate-static (RM 4.3.2(16-22)) 38.subtype I3 is Integer with -- OK 39. Dynamic_Predicate = (I3 + 1) 0 and 4 I3; 40.subtype I4 is Integer with -- OK 41. Predicate = (I4 + 1) 0 and 4 I4; 42. 43.subtype I5 is Integer with -- ERROR 44. Static_Predicate = Boolean'(I5 0); | expression is not predicate-static (RM 4.3.2(16-22)) 45. 46.XF1 : constant F1 := 10.0; -- WARN | warning: static expression fails static predicate check on F1, expression is no longer considered static 47.XF2 : constant F1 := 3.0; -- OK 48. 49.XF3 : constant := XF1; -- ERROR | non-static expression used in number declaration XF1 is not a static constant (RM 4.9(5)) 50.XF4 : constant := XF2; -- OK 51. 52.XF1a : constant F1a := 1.3; -- WARN; | warning: static expression fails static predicate check on F1a, expression is no longer considered static 53.XF1b : constant F1a := 5.3; -- WARN; | warning: static expression fails static predicate check on F1a, expression is no longer considered static 54.XF1c : constant F1a := 3.7; -- OK 55. 56.XI1 : constant I1 := 10; -- WARN | warning: static expression fails static predicate check on I1, expression is no longer considered static 57.XI2 : constant I1 := 3; -- OK 58. 59.XI3 : constant := XI1; -- ERROR | non-static expression used in number declaration XI1 is not a static constant (RM 4.9(5)) 60.XI4 : constant := XI2; -- OK 61. 62.XI1a : constant I1a := 2; -- WARN | warning: static expression fails static predicate check on I1a, expression is no longer considered static 63.XI1b : constant I1a := 7; -- WARN | warning: static expression fails static predicate check on I1a, expression is no longer considered static 64.XI1c : constant I1a := 3; -- OK 65. 66.XSa : constant S1 := ABC; -- OK 67. 68.Xsb : constant S1 := DQR; -- WARN | warning:
[Ada] New pragma Default_Scalar_Storage_Order
Normally the default scalar storage order is the native order of the target. This pragma, which can be either a configuration pragma, or appear in a package spec or declarative part, can provide a default value that overrides this normal default. If used in a package spec or declarative part, it applies to the following declarations of array and record types in that package spec or declarative part. The following example shows the pragma in action: 1. pragma Default_Scalar_Storage_Order 2. (High_Order_First); 3. with System; use System; 4. package DSSO1 is 5.type H1 is record 6. -- High from config pragma 7. a : Integer; 8.end record; 9.for H1 use record 10. a at 0 range 0 .. 31; 11.end record; 12. 13.type L2 is record 14. -- Low from explicit setting 15. a : Integer; 16.end record; 17.for L2 use record 18. a at 0 range 0 .. 31; 19.end record; 20.for L2'Scalar_Storage_Order 21.use Low_Order_First; 22. 23.type L2a is new L2; 24.-- Low (inherited from explicit) 25. 26.package Inner is 27. type H3 is record 28. -- High from outer config pragma 29. a : Integer; 30. end record; 31. for H3 use record 32. a at 0 range 0 .. 31; 33. end record; 34. 35. pragma Default_Scalar_Storage_Order 36.(Low_Order_First); 37. 38. type L4 is record 39. -- Low from inner default 40. a : Integer; 41. end record; 42. for L4 use record 43. a at 0 range 0 .. 31; 44. end record; 45.end Inner; 46. 47.type H4a is new Inner.L4; 48.-- High from config pragma 49.-- No inheritance of default setting 50. 51.type H5 is record 52. -- High from config pragma 53. a : Integer; 54.end record; 55.for H5 use record 56. a at 0 range 0 .. 31; 57.end record; 58. end DSSO1; If this is compiled with -gnatR and we select the lines that mention scalar storage order, we get: for H1'Scalar_Storage_Order use System.High_Order_First; for L2'Scalar_Storage_Order use System.Low_Order_First; for L2A'Scalar_Storage_Order use System.Low_Order_First; for INNER.H3'Scalar_Storage_Order use System.High_Order_First; for INNER.L4'Scalar_Storage_Order use System.Low_Order_First; for H4A'Scalar_Storage_Order use System.High_Order_First; for H5'Scalar_Storage_Order use System.High_Order_First; If the pragma is used in a configuration pragmas file, then the binder will require that all units, including all run-time library units, be compiled the same way (with a pragma in a configuration pragma file with matching order). Given the following file: 1. with DSSO1; 2. procedure DSSOm is 3.type R is record 4. N : Integer; 5.end record; 6.for R use record 7. N at 0 range 0 .. 31; 8.end record; 9. begin 10.null; 11. end; If we compile DSSom with a configuration file containing a pragma specifying Low_Order_First, and then compile DSSO1 with a configuration file containing a pragma specifying High_Order_First, and then do a bind operation, we get something like (exactly list of run-time files may vary): error: files not compiled with same Default_Scalar_Storage_Order files compiled with High_Order_First dssom.adb files compiled with Low_Order_First dsso1.ads files compiled with no Default_Scalar_Storage_Order s-stalib.adb system.ads s-memory.adb ada.ads a-except.adb a-elchha.adb s-soflin.adb s-parame.adb s-secsta.adb s-stoele.adb s-stache.adb s-exctab.adb s-except.adb s-excmac.ads s-excdeb.adb s-imgint.adb interfac.ads s-assert.adb s-traceb.adb s-wchcon.adb s-wchstw.adb s-wchcnv.adb s-wchjis.adb s-traent.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar de...@adacore.com * ali.adb (Initialize_ALI): Initialize SSO_Default_Specified (Scan_ALI): Set SSO_Default in ALIs_Record (Scan_ALI): Set SSO_Default_Specified. * ali.ads (ALIs_Record): Add field SSO_Default (SSO_Default_Specified): New global switch. * bcheck.adb (Check_Consistent_SSO_Default): New procedure (Check_Configuration_Consistency): Call this procedure * einfo.adb (SSO_Set_High_By_Default): New function (SSO_Set_Low_By_Default): New function (Set_SSO_Set_High_By_Default): New procedure (Set_SSO_Set_Low_By_Default): New procedure (Write_Entity_Flags): List new flags * einfo.ads (SSO_Set_Low_By_Default): New flag (SSO_Set_High_By_Default): New flag * freeze.adb (Set_SSO_From_Default): New procedure
[Ada] Fix problem with Error arg for Unevaluated_Use_Of_Old
The Error option for pragma Unevaluated_Use_Of_Old was not properly recognized, due to an internal problem with the generation of the names table for the Snames package. This is now corrected, and the following program compiles as shown with -gnatld7 -gnatj60: 1. package Uneval_Old is 2.pragma Unevaluated_Use_Of_Old (Error); 3.function F (X : Integer) return Integer; 4.procedure P (X : in out Integer) with 5. Post = (if X 0 then X = F(X)'Old + 1); | prefix of attribute Old that is potentially unevaluated must denote an entity 6. end Uneval_Old; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar de...@adacore.com * snames.ads-tmpl: Minor reformatting. * xsnamest.adb (XSnamesT): Remove special casing of Name_Error to give Error. Not clear why this was there, but the compiler sources do not reference Name_Error, and this interfered with the circuits for pragma Unevaluated_Use_Of_Old. Index: xsnamest.adb === --- xsnamest.adb(revision 213156) +++ xsnamest.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -255,10 +255,6 @@ Name0 := 'O' Translate (Name0, Lower_Case_Map); end if; -if Name0 = error then - Name0 := V (error); -end if; - if not Match (Name0, Chk_Low) then Put_Line (OutB,Name0 # ); end if; Index: snames.ads-tmpl === --- snames.ads-tmpl (revision 213160) +++ snames.ads-tmpl (working copy) @@ -56,8 +56,8 @@ -- First we have the one character names used to optimize the lookup -- process for one character identifiers (to avoid the hashing in this - -- case) There are a full 256 of these, but only the entries for lower case - -- and upper case letters have identifiers + -- case) There are a full 256 of these, but only the entries for lower + -- case and upper case letters have identifiers -- The lower case letter entries are used for one character identifiers -- appearing in the source, for example in pragma Interface (C).
[Ada] Implement SPARK RM C.6 rules
This patch implements the following set of rules related to shared variables: 1. A volatile representation aspect may only be applied to an object_declaration or a full_type_declaration. 2. A component of a non-volatile type declaration shall not be volatile. 3. A discriminant shall not be volatile. 4. Neither a discriminated type nor an object of such a type shall be volatile. 5. Neither a tagged type nor an object of such a type shall be volatile. 6. A volatile variable shall only be declared at library-level. -- Source -- -- shared_vars.ads package Shared_Vars 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; 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; SV2 : R7 with Volatile; -- illegal, SPARK RM C.6(5) end Shared_Vars; -- Compilation and output -- $ gcc -c shared_vars.ads hared_vars.ads:8:25: entity for aspect Volatile must denote a full type or object declaration shared_vars.ads:14:07: component F2 of non-volatile type R2 cannot be volatile shared_vars.ads:17:13: discriminant cannot be volatile shared_vars.ads:21:09: discriminated type R4 cannot be volatile shared_vars.ads:29:04: discriminated object SV cannot be volatile shared_vars.ads:31:09: tagged type R6 cannot be volatile shared_vars.ads:39:04: tagged object SV2 cannot be volatile Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Hristian Kirtchev kirtc...@adacore.com * freeze.adb (Freeze_Record_Type): Perform various volatility-related checks. Index: freeze.adb === --- freeze.adb (revision 213169) +++ freeze.adb (working copy) @@ -3411,6 +3411,43 @@ end if; end if; + -- The following checks are only relevant when SPARK_Mode is on as + -- they are not standard Ada legality rules. + + if SPARK_Mode = On then +if Is_SPARK_Volatile (Rec) then + + -- A discriminated type cannot be volatile (SPARK RM C.6(4)) + + if Has_Discriminants (Rec) then + Error_Msg_N (discriminated type cannot be volatile, Rec); + + -- A tagged type cannot be volatile (SPARK RM C.6(5)) + + elsif Is_Tagged_Type (Rec) then + Error_Msg_N (tagged type cannot be volatile, Rec); + end if; + +-- A non-volatile record type cannot contain volatile components +-- (SPARK RM C.6(2)) + +else + Comp := First_Component (Rec); + while Present (Comp) loop + if Comes_From_Source (Comp) +and then Is_SPARK_Volatile (Etype (Comp)) + then + Error_Msg_Name_1 := Chars (Rec); + Error_Msg_N + (component of non-volatile type % cannot be + volatile, Comp); + end if; + + Next_Component (Comp); + end loop; +end if; + end if; + -- All done if not a full record definition if Ekind (Rec) /= E_Record_Type then
[Ada] Out parameters of a null-excluding access type in entries.
If a procedure or entry has an formal out-parameter of a null-excluding access type, there is no check applied to the actual before the call. This patch removes a spurious access check on such parameters on entry calls. Compiling and executing p.adb must yield; Procedure version did not raise exception Entry version did not raise exception --- with Ada.Text_IO; use Ada.Text_IO; procedure P is type Integer_Access is access all Integer; An_Integer : aliased Integer; procedure Procedure_Version (A : out not null Integer_Access) is begin A := An_Integer'Access; end Procedure_Version; protected Object is entry Entry_Version (A : out not null Integer_Access); end Object; protected body Object is entry Entry_Version (A : out not null Integer_Access) when True is Junk : integer := 0; begin A := An_Integer'Access; end Entry_Version; end Object; A : Integer_Access; begin A := null; Procedure_Version (A); Put_Line (Procedure version did not raise exception); A := null; Object.Entry_Version (A); Put_Line (Entry version did not raise exception); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Ed Schonberg schonb...@adacore.com * exp_ch5.adb (Expand_N_Assignment_Statement): If the target type is a null-excluding access type, do not generate a constraint check if Suppress_Assignment_Checks is set on assignment node. * exp_ch9.adb (Build_Simple_Entry_Call): If actual is an out parameter of a null-excluding access type, there is access check on entry, so set Suppress_Assignment_Checks on generated statement that assigns actual to parameter block. * sinfo.ads: Document additional use of Suppress_Assignment_Checks. Index: exp_ch5.adb === --- exp_ch5.adb (revision 213163) +++ exp_ch5.adb (working copy) @@ -2001,6 +2001,7 @@ if Is_Access_Type (Typ) and then Can_Never_Be_Null (Etype (Lhs)) and then not Can_Never_Be_Null (Etype (Rhs)) +and then not Suppress_Assignment_Checks (N) then Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; Index: sinfo.ads === --- sinfo.ads (revision 213194) +++ sinfo.ads (working copy) @@ -2052,7 +2052,9 @@ --and range checks in cases where the generated code knows that the --value being assigned is in range and satisfies any predicate. Also --can be set in N_Object_Declaration nodes, to similarly suppress any - --checks on the initializing value. + --checks on the initializing value. In assignment statements it also + --suppresses access checks in the generated code for out- and in-out + --parameters in entry calls. -- Suppress_Loop_Warnings (Flag17-Sem) --Used in N_Loop_Statement node to indicate that warnings within the Index: exp_ch9.adb === --- exp_ch9.adb (revision 213159) +++ exp_ch9.adb (working copy) @@ -4755,7 +4755,8 @@ -- case of limited type. We cannot assign it unless the -- Assignment_OK flag is set first. An out formal of an -- access type must also be initialized from the actual, - -- as stated in RM 6.4.1 (13). + -- as stated in RM 6.4.1 (13), but no constraint is applied + -- before the call. if Ekind (Formal) /= E_Out_Parameter or else Is_Access_Type (Etype (Formal)) @@ -4767,6 +4768,7 @@ Make_Assignment_Statement (Loc, Name = N_Var, Expression = Relocate_Node (Actual))); + Set_Suppress_Assignment_Checks (Last (Stats)); end if; Append (N_Node, Decls);
[Ada] PR ada/60652 - Wrong value for System.OS_Constants.CRTSCTS
On Linux, s-oscons-tmplt.c needs to define _BSD_SOURCE in order for CRTSCTS to be visible. Otherwise the macro is undefined, and defaulted to -1. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Thomas Quinot qui...@adacore.com PR ada/60652 * s-oscons-tmplt.c: For Linux, define _BSD_SOURCE in order for CRTSCTS to be visible. Index: s-oscons-tmplt.c === --- s-oscons-tmplt.c(revision 213156) +++ s-oscons-tmplt.c(working copy) @@ -86,11 +86,18 @@ ** a number of non-POSIX but useful/required features. **/ -#if defined (__linux__) !defined (_XOPEN_SOURCE) -/* For Linux, define _XOPEN_SOURCE to get IOV_MAX */ -#define _XOPEN_SOURCE 500 -#endif +#if defined (__linux__) +/* Define _XOPEN_SOURCE to get IOV_MAX */ +# if !defined (_XOPEN_SOURCE) +# define _XOPEN_SOURCE 500 +# endif + +/* Define _BSD_SOURCE to get CRTSCTS */ +# define _BSD_SOURCE + +#endif /* defined (__linux__) */ + /* Include gsocket.h before any system header so it can redefine FD_SETSIZE */ #include gsocket.h
[Ada] Selectively inline subprograms in GNATprove mode
For formal verification with GNATprove, frontend inlining can be used to relieve users from the need to add contracts to local subprograms. Thus, we adopt here a simple policy for inlining in GNATprove mode, which consists in inlining all local subprograms which can be inlined, as soon as they don't have a contract. This policy gives to the user the control over which subprograms may be inlined. This is under debug flag -gnatdQ for now, until remaining issues have been fixed. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Yannick Moy m...@adacore.com * debug.adb Enable GNATprove inlining under debug flag -gnatdQ for now. * inline.ads, inline.adb (Can_Be_Inlined_In_GNATprove_Mode): New function to decide when a subprogram can be inlined in GNATprove mode. (Check_And_Build_Body_To_Inline): Include GNATprove_Mode as a condition for possible inlining. * sem_ch10.adb (Analyze_Compilation_Unit): Remove special case for Inline_Always in GNATprove mode. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build inlined body for subprograms in GNATprove mode, under debug flag -gnatdQ. * sem_prag.adb Minor change in comments. * sem_res.adb (Resolve_Call): Only perform GNATprove inlining inside subprograms marked as SPARK_Mode On. * sinfo.ads Minor typo fix. Index: sinfo.ads === --- sinfo.ads (revision 213201) +++ sinfo.ads (working copy) @@ -817,7 +817,7 @@ --set, it means that the front end can assure no overlap of operands. -- Body_To_Inline (Node3-Sem) - --present in subprogram declarations. Denotes analyzed but unexpanded + --Present in subprogram declarations. Denotes analyzed but unexpanded --body of subprogram, to be used when inlining calls. Present when the --subprogram has an Inline pragma and inlining is enabled. If the --declaration is completed by a renaming_as_body, and the renamed en- Index: inline.adb === --- inline.adb (revision 213201) +++ inline.adb (working copy) @@ -44,8 +44,10 @@ with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo;use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Stand;use Stand; with Uname;use Uname; @@ -1257,12 +1259,13 @@ end if; end if; - -- We do not inline a subprogram that is too large, unless it is - -- marked Inline_Always. This pragma does not suppress the other - -- checks on inlining (forbidden declarations, handlers, etc). + -- We do not inline a subprogram that is too large, unless it is marked + -- Inline_Always or we are in GNATprove mode. This pragma does not + -- suppress the other checks on inlining (forbidden declarations, + -- handlers, etc). if Stat_Count Max_Size -and then not Has_Pragma_Inline_Always (Subp) +and then not (Has_Pragma_Inline_Always (Subp) or else GNATprove_Mode) then Cannot_Inline (cannot inline (body too large)?, N, Subp); return; @@ -1454,6 +1457,152 @@ end if; end Cannot_Inline; + -- + -- Can_Be_Inlined_In_GNATprove_Mode -- + -- + + function Can_Be_Inlined_In_GNATprove_Mode + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean + is + function Has_Some_Contract (Id : Entity_Id) return Boolean; + -- Returns True if subprogram Id has any contract (Pre, Post, Global, + -- Depends, etc.) + + function In_Some_Private_Part (N : Node_Id) return Boolean; + -- Returns True if node N is defined in the private part of a package + + function In_Unit_Body (N : Node_Id) return Boolean; + -- Returns True if node N is defined in the body of a unit + + function Is_Expression_Function (Id : Entity_Id) return Boolean; + -- Returns True if subprogram Id was defined originally as an expression + -- function. + + --- + -- Has_Some_Contract -- + --- + + function Has_Some_Contract (Id : Entity_Id) return Boolean is + Items : constant Node_Id := Contract (Id); + begin + return Present (Items) + and then (Present (Pre_Post_Conditions (Items)) + or else + Present (Contract_Test_Cases (Items)) + or else + Present (Classifications (Items))); + end Has_Some_Contract; + + -- + -- In_Some_Private_Part -- + -- + + function In_Some_Private_Part (N : Node_Id) return Boolean is + P : Node_Id := N; +
[Ada] Apply proper predicate tests to OUT and IN OUT parameters
This fix is inspired by ACATS test C324002, which tests that predicate tests for OUT and IN OUT parameters are properly applied. They were missed in some cases, and applied when they should not be to Finalize procedures. The following three tests (cutdown versions of C324002) compile and execute quietly: 1. with Ada.Assertions; use Ada.Assertions; 2. procedure PredByRef1 is 3.pragma Assertion_Policy (Check); 4.type R is tagged record 5. X : Integer; 6.end record 7.with Dynamic_Predicate = R.X mod 2 = 0; 8. 9.RV : R := (X = 0); 10. 11.procedure P (Arg : in out R) is 12.begin 13. Arg.X := Arg.X + 1; 14.end; 15. 16. begin 17.P (RV); 18.raise Program_Error; 19. exception 20.when Assertion_Error = null; 21. end PredByRef1; 1. with Ada.Assertions; use Ada.Assertions; 2. with Ada.Finalization; use Ada.Finalization; 3. procedure PredByRef2 is 4.pragma Assertion_Policy (Check); 5.type R is new Controlled with record 6. X : Integer := 0; 7.end record 8.with Dynamic_Predicate = R.X mod 2 = 0; 9. 10.RV : R; 11. 12.procedure P (Arg : in out R) is 13.begin 14. Arg.X := Arg.X + 1; 15.end; 16. 17. begin 18.P (RV); 19.raise Program_Error; 20. exception 21.when Assertion_Error = null; 22. end PredByRef2; 1. with Ada.Finalization; 2. with Ada.Assertions; use Ada.Assertions; 3. procedure PredByRef3 is 4.pragma Assertion_Policy (Check); 5.type String_Access is access all String; 6. 7.type Unbounded_String is new 8. Ada.Finalization.Controlled with record 9. Length : Natural := 100; 10.end record; 11. 12.subtype Max_10_Char_String is Unbounded_String 13. with Dynamic_Predicate = 14. Max_10_Char_String.Length = 10; 15. 16.procedure Set_Unbounded_String 17. (Target : out Unbounded_String) is 18.begin 19. Target.Length := 200; 20.end Set_Unbounded_String; 21. 22.Our_Data : array (1 .. 10) of Max_10_Char_String 23. begin 24.Set_Unbounded_String (Our_Data(6)); 25.raise Program_Error; 26. exception 27.when Assertion_Error = null; 28. end PredByRef3; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Robert Dewar de...@adacore.com * exp_ch6.adb (Add_Call_By_Copy_Code): Minor reformatting (Expand_Actuals): Make sure predicate checks are properly applied for the case of OUT or IN OUT parameters. * sem_res.adb: Minor reformatting (Resolve_Actuals): Skip predicate tests on arguments for Finalize * sem_util.adb (No_Predicate_Test_On_Arguments): Returns True if predicate tests on subprogram arguments should be skipped. * sem_util.ads (No_Predicate_Test_On_Arguments): New function Index: sem_util.adb === --- sem_util.adb(revision 213208) +++ sem_util.adb(working copy) @@ -13785,6 +13785,44 @@ Actual_Id := Next_Actual (Actual_Id); end Next_Actual; + + -- No_Predicate_Test_On_Arguments -- + + + function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean is + begin + -- Do not test predicates on call to generated default Finalize, since + -- we are not interested in whether something we are finalizing (and + -- typically destroying) satisfies its predicates. + + if Chars (Subp) = Name_Finalize +and then not Comes_From_Source (Subp) + then + return True; + + -- Do not test predicates on call to Init_Proc, since if needed the + -- predicate test will occur at some other point. + + elsif Is_Init_Proc (Subp) then + return True; + + -- Do not test predicates on call to predicate function, since this + -- would cause infinite recursion. + + elsif Ekind (Subp) = E_Function +and then (Is_Predicate_Function (Subp) +or else + Is_Predicate_Function_M (Subp)) + then + return True; + + -- For now, no other cases + + else + return False; + end if; + end No_Predicate_Test_On_Arguments; + - -- No_Scalar_Parts -- - Index: sem_util.ads === --- sem_util.ads(revision 213206) +++ sem_util.ads(working copy) @@ -1582,6 +1582,11 @@ -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. + function
[Ada] Small cleanup in array aggregate handling code
This removes a subprogram which serves no useful purpose and changes the affected case to use the common code path. No functional changes. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-29 Eric Botcazou ebotca...@adacore.com * exp_aggr.adb (Safe_Slice_Assignment): Remove. (Expand_Array_Aggregate): For a safe slice assignment, just set the target and use the common code path. Index: exp_aggr.adb === --- exp_aggr.adb(revision 213201) +++ exp_aggr.adb(working copy) @@ -289,11 +289,6 @@ -- If this transformation is not possible, N is unchanged and False is -- returned. - function Safe_Slice_Assignment (N : Node_Id) return Boolean; - -- If a slice assignment has an aggregate with a single others_choice, - -- the assignment can be done in place even if bounds are not static, - -- by converting it into a loop over the discrete range of the slice. - function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean; -- If the type of the aggregate is a two-dimensional bit_packed array -- it may be transformed into an array of bytes with constant values, @@ -404,8 +399,8 @@ elsif Restriction_Active (No_Elaboration_Code) or else Restriction_Active (No_Implicit_Loops) or else Is_Two_Dim_Packed_Array (Typ) -or else ((Ekind (Current_Scope) = E_Package - and then Static_Elaboration_Desired (Current_Scope))) +or else (Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope)) then Max_Aggr_Size := 2 ** 24; @@ -443,9 +438,7 @@ -- is an object declaration with non-static bounds it will trip gcc; -- such an aggregate must be expanded into a single assignment. - if Hiv = Lov - and then Nkind (Parent (N)) = N_Object_Declaration - then + if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then declare Index_Type : constant Entity_Id := Etype @@ -454,8 +447,8 @@ begin if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) - or else not Compile_Time_Known_Value -(Type_High_Bound (Index_Type)) + or else not Compile_Time_Known_Value + (Type_High_Bound (Index_Type)) then if Present (Component_Associations (N)) then Indx := @@ -603,7 +596,7 @@ -- Recursion to following indexes for multiple dimension case if Present (Next_Index (Index)) - and then not Component_Check (Expr, Next_Index (Index)) + and then not Component_Check (Expr, Next_Index (Index)) then return False; end if; @@ -653,11 +646,11 @@ end if; -- Checks 5 (if the component type is tagged, then we may need to do - --tag adjustments. Perhaps this should be refined to check for any - --component associations that actually need tag adjustment, similar - --to the test in Component_Not_OK_For_Backend for record aggregates - --with tagged components, but not clear whether it's worthwhile ???; - --in the case of the JVM, object tags are handled implicitly) + -- tag adjustments. Perhaps this should be refined to check for any + -- component associations that actually need tag adjustment, similar + -- to the test in Component_Not_OK_For_Backend for record aggregates + -- with tagged components, but not clear whether it's worthwhile ???; + -- in the case of the JVM, object tags are handled implicitly) if Is_Tagged_Type (Component_Type (Typ)) and then Tagged_Type_Expansion @@ -934,7 +927,8 @@ end case; if Local_Compile_Time_Known_Value (Low) - and then Local_Compile_Time_Known_Value (High) + and then + Local_Compile_Time_Known_Value (High) then Is_Empty := UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); @@ -956,7 +950,8 @@ return True; elsif Local_Compile_Time_Known_Value (L) - and then Local_Compile_Time_Known_Value (H) + and then + Local_Compile_Time_Known_Value (H) then return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); end if; @@ -1053,9 +1048,7 @@ Expr_Q := Expr; end if; - if Present (Etype (N)) - and then Etype (N) /= Any_Composite - then + if Present (Etype (N)) and then Etype (N) /= Any_Composite then Comp_Type := Component_Type (Etype (N)); pragma Assert (Comp_Type = Ctype); --
[Ada] Internal cleanup for Predicate_Tests_On_Arguments
Some additional cases of internal routines are now detected and skip predicate tests on arguments. Not clear if this fixes additional problems or not, but it is certainly a desirable change. No further test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Robert Dewar de...@adacore.com * sem_util.adb (Predicate_Tests_On_Arguments): Omit tests for some additional cases of internally generated routines. Index: sem_util.adb === --- sem_util.adb(revision 213212) +++ sem_util.adb(working copy) @@ -14723,32 +14723,42 @@ function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is begin + -- Always test predicates on indirect call + + if Ekind (Subp) = E_Subprogram_Type then + return True; + -- Do not test predicates on call to generated default Finalize, since -- we are not interested in whether something we are finalizing (and -- typically destroying) satisfies its predicates. - if Chars (Subp) = Name_Finalize + elsif Chars (Subp) = Name_Finalize and then not Comes_From_Source (Subp) then return False; - -- Do not test predicates on call to Init_Proc, since if needed the - -- predicate test will occur at some other point. + -- Do not test predicates on any internally generated routines + elsif Is_Internal_Name (Chars (Subp)) then + return False; + + -- Do not test predicates on call to Init_Proc, since if needed the + -- predicate test will occur at some other point. + elsif Is_Init_Proc (Subp) then return False; - -- Do not test predicates on call to predicate function, since this - -- would cause infinite recursion. + -- Do not test predicates on call to predicate function, since this + -- would cause infinite recursion. elsif Ekind (Subp) = E_Function and then (Is_Predicate_Function (Subp) - or else +or else Is_Predicate_Function_M (Subp)) then return False; - -- For now, no other exceptions + -- For now, no other exceptions else return True;
[Ada] Inheritance of variables in extending projects
A variable V declared in a project A that is extended by a project B is now inherited in project B; it can be referenced as V in project B or as B.V in any other project that imports B. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Vincent Celier cel...@adacore.com * prj-proc.adb (Imported_Or_Extended_Project_From): New Boolean parameter No_Extending, defaulted to False. When No_Extending is True, do not look for an extending project. (Expression): For a variable reference that is not for the current project, get its Id calling Imported_Or_Extended_Project_From with No_Extending set to True. * prj-strt.adb (Parse_Variable_Reference): If a referenced variable is not found in the current project, check if it is defined in one of the projects it extends. Index: prj-proc.adb === --- prj-proc.adb(revision 213201) +++ prj-proc.adb(working copy) @@ -118,8 +118,9 @@ -- of an expression and return it as a Variable_Value. function Imported_Or_Extended_Project_From - (Project : Project_Id; - With_Name : Name_Id) return Project_Id; + (Project : Project_Id; + With_Name: Name_Id; + No_Extending : Boolean := False) return Project_Id; -- Find an imported or extended project of Project whose name is With_Name function Package_From @@ -705,8 +706,9 @@ The_Name := Name_Of (Term_Project, From_Project_Node_Tree); The_Project := Imported_Or_Extended_Project_From - (Project = Project, - With_Name = The_Name); + (Project = Project, + With_Name= The_Name, + No_Extending = True); end if; if Present (Term_Package) then @@ -1261,8 +1263,9 @@ --- function Imported_Or_Extended_Project_From - (Project : Project_Id; - With_Name : Name_Id) return Project_Id + (Project : Project_Id; + With_Name: Name_Id; + No_Extending : Boolean := False) return Project_Id is List: Project_List; Result : Project_Id; @@ -1304,7 +1307,12 @@ Proj := Result.Extends; while Proj /= No_Project loop if Proj.Name = With_Name then - Temp_Result := Result; + if No_Extending then + Temp_Result := Proj; + else + Temp_Result := Result; + end if; + exit; end if; Index: prj-strt.adb === --- prj-strt.adb(revision 213201) +++ prj-strt.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -1162,7 +1162,7 @@ -- If we have not found the variable in the package, check if the -- variable has been declared in the project, or in any of its --- ancestors. +-- ancestors, or in any of the project it extends. if No (Current_Variable) then declare @@ -1182,8 +1182,15 @@ exit when Present (Current_Variable); - Proj := Parent_Project_Of (Proj, In_Tree); + if No (Parent_Project_Of (Proj, In_Tree)) then +Proj := + Extended_Project_Of +(Project_Declaration_Of (Proj, In_Tree), In_Tree); + else +Proj := Parent_Project_Of (Proj, In_Tree); + end if; + Set_Project_Node_Of (Variable, In_Tree, To = Proj); exit when No (Proj);
[Ada] Improve run time performance for large array reset
This patch makes the compiler generate faster code to reset a large array of integers to 0 by means of an aggregate with a single Others choice and, more generally, to set a large array of storage units to a single value by the same means, for example: type Arr is array (1 .. 1) of Integer; A : Arr := (others = 0); Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Eric Botcazou ebotca...@adacore.com * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): New predicate. (Expand_Array_Aggregate): Also enable in-place expansion for code generated by the compiler. For an object declaration, set the kind of the object in addition to its type. If an in-place assignment is to be generated and it can be directly done by the back-end, do not expand the aggregate. * fe.h (Is_Others_Aggregate): Declare. * gcc-interface/trans.c (gnat_to_gnu) N_Assignment_Statement: Add support for an aggregate with a single Others choice on the RHS by means of __builtin_memset. Tidy up. Index: fe.h === --- fe.h(revision 213201) +++ fe.h(working copy) @@ -202,6 +202,11 @@ extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); +/* sem_aggr: */ +#define Is_Others_Aggregatesem_aggr__is_others_aggregate + +extern Boolean Is_Others_Aggregate (Node_Id); + /* sem_aux: */ #define Ancestor_Subtype sem_aux__ancestor_subtype Index: exp_aggr.adb === --- exp_aggr.adb(revision 213216) +++ exp_aggr.adb(working copy) @@ -3945,6 +3945,9 @@ Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; -- The type of each index + In_Place_Assign_OK_For_Declaration : Boolean := False; + -- True if we are to generate an in place assignment for a declaration + Maybe_In_Place_OK : Boolean; -- If the type is neither controlled nor packed and the aggregate -- is the expression in an assignment, assignment in place may be @@ -3955,6 +3958,9 @@ -- If Others_Present (J) is True, then there is an others choice -- in one of the sub-aggregates of N at dimension J. + function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean; + -- Returns true if an aggregate assignment can be done by the back end + procedure Build_Constrained_Type (Positional : Boolean); -- If the subtype is not static or unconstrained, build a constrained -- type using the computable sizes of the aggregate and its sub- @@ -3991,6 +3997,108 @@ -- built directly into the target of the assignment it must be free -- of side-effects. + + -- Aggr_Assignment_OK_For_Backend -- + + + -- Backend processing by Gigi/gcc is possible only if all the following + -- conditions are met: + + --1. N consists of a single OTHERS choice, possibly recursively + + --2. The component type is discrete + + --3. The component size is a multiple of Storage_Unit + + --4. The component size is exactly Storage_Unit or the expression is + -- an integer whose unsigned value is the binary concatenation of + -- K times its remainder modulo 2**Storage_Unit. + + -- The ultimate goal is to generate a call to a fast memset routine + -- specifically optimized for the target. + + function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is + Ctyp : Entity_Id; + Expr : Node_Id := N; + Remainder : Uint; + Value : Uint; + Nunits: Nat; + + begin + -- Recurse as far as possible to find the innermost component type + + Ctyp := Etype (N); + while Is_Array_Type (Ctyp) loop +if Nkind (Expr) /= N_Aggregate + or else not Is_Others_Aggregate (Expr) +then + return False; +end if; + +Expr := Expression (First (Component_Associations (Expr))); + +for J in 1 .. Number_Dimensions (Ctyp) - 1 loop + if Nkind (Expr) /= N_Aggregate + or else not Is_Others_Aggregate (Expr) + then + return False; + end if; + + Expr := Expression (First (Component_Associations (Expr))); +end loop; + +Ctyp := Component_Type (Ctyp); + end loop; + + if not Is_Discrete_Type (Ctyp) + or else RM_Size (Ctyp) mod System_Storage_Unit /= 0 + then +return False; + end if; + + -- The expression needs to be analyzed if True is returned + + Analyze_And_Resolve (Expr, Ctyp); + +
[Ada] New unit GNAT.Formatted_String providing C/C++ format string support
The following code:
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Formatted_String; use GNAT.Formatted_String;
procedure Fout is
F : Formatted_String := +%c %% %#08x;
Vc : Character := 'v';
Vi : Integer := 12;
begin
F := F Vc Vi;
Put_Line (-F);
end Fout;
Should output:
v % 0x0c
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-30 Pascal Obry o...@adacore.com
* g-forstr.adb, g-forstr.ads: New.
* gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit
GNAT.Formatted_String.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 213240)
+++ gnat_rm.texi(working copy)
@@ -594,6 +594,7 @@
* GNAT.Expect (g-expect.ads)::
* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
* GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -18934,6 +18935,7 @@
* GNAT.Expect (g-expect.ads)::
* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
* GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -19860,6 +19862,18 @@
library calls may cause this mode to be modified, and the Reset procedure
in this package can be used to reestablish the required mode.
+@node GNAT.Formatted_String (g-forstr.ads)
+@section @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex Formatted String
+
+@noindent
+Provides support for C/C++ printf() formatted string. The format is
+copied from the printf() routine and should therefore gives identical
+output. Some generic routines are provided to be able to use types
+derived from Integer, Float or enumerations as values for the
+formatted string.
+
@node GNAT.Heap_Sort (g-heasor.ads)
@section @code{GNAT.Heap_Sort} (@file{g-heasor.ads})
@cindex @code{GNAT.Heap_Sort} (@file{g-heasor.ads})
Index: impunit.adb
===
--- impunit.adb (revision 213201)
+++ impunit.adb (working copy)
@@ -273,6 +273,7 @@
(g-expect, F), -- GNAT.Expect
(g-exptty, F), -- GNAT.Expect.TTY
(g-flocon, F), -- GNAT.Float_Control
+(g-forstr, F), -- GNAT.Formatted_String
(g-heasor, F), -- GNAT.Heap_Sort
(g-hesora, F), -- GNAT.Heap_Sort_A
(g-hesorg, F), -- GNAT.Heap_Sort_G
Index: Makefile.rtl
===
--- Makefile.rtl(revision 213201)
+++ Makefile.rtl(working copy)
@@ -411,6 +411,7 @@
g-expect$(objext) \
g-exptty$(objext) \
g-flocon$(objext) \
+ g-forstr$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
g-hesorg$(objext) \
Index: g-forstr.adb
===
--- g-forstr.adb(revision 0)
+++ g-forstr.adb(revision 0)
@@ -0,0 +1,951 @@
+--
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+--G N A T . F O R M A T T E D _ S T R I N G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and--
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If
[Ada] Illegal external aspects not detected
This patch modifies the categorization of aspects Async_Readers, Async_Writers, Effective_Reads and Effective_Writes to no longer require delayed actions. This in turn ensures that the analysis of their aspect form correctly creates their pragma counterparts. -- Source -- -- illegal_externals.ads package Illegal_Externals with SPARK_Mode = On is type I is range 1 .. 10 with Async_Readers; type I2 is range 1 .. 10 with Async_Readers = True; type I3 is range 1 .. 10 with Async_Readers = False; type T1 is array (I) of Integer with Volatile; type T2 is array (I) of Integer with Volatile, Async_Readers= True, Async_Writers= False, Effective_Writes = False, Effective_Reads = False; subtype S1 is Integer range 1 .. 10 with Async_Readers; subtype S2 is Integer range 1 .. 10 with Async_Readers = True; subtype S3 is Integer range 1 .. 10 with Async_Readers = False; procedure P1 with Import, Convention = C; procedure P2 with Import, Async_Readers, Convention = C; end Illegal_Externals; -- Compilation and output -- $ gcc -c illegal_externals.ads illegal_externals.ads:2:34: aspect Async_Readers must apply to a volatile object illegal_externals.ads:3:34: aspect Async_Readers must apply to a volatile object illegal_externals.ads:4:34: aspect Async_Readers must apply to a volatile object illegal_externals.ads:8:11: aspect Async_Readers must apply to a volatile object illegal_externals.ads:9:11: aspect Async_Writers must apply to a volatile object illegal_externals.ads:10:11: aspect Effective_Writes must apply to a volatile object illegal_externals.ads:11:11: aspect Effective_Reads must apply to a volatile object illegal_externals.ads:12:45: aspect Async_Readers must apply to a volatile object illegal_externals.ads:13:45: aspect Async_Readers must apply to a volatile object illegal_externals.ads:14:45: aspect Async_Readers must apply to a volatile object illegal_externals.ads:20:11: aspect Async_Readers must apply to a volatile object Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Hristian Kirtchev kirtc...@adacore.com * aspects.ads Aspects Async_Readers, Async_Writers, Effective_Reads and Effective_Writes do not need to be delayed. * sem_ch13.adb (Analyze_Aspect_Specifications): Propagate the optional Boolean expression when generating the corresponding pragma for an external property aspect. * sem_prag.adb (Analyze_External_Property_In_Decl_Part): Remove local constant Obj. Add local constant Obj_Id. Reimplement the check which ensures that the related variable is in fact volatile. (Analyze_Pragma): Reimplement the analysis of external property pragmas. * sem_util.adb (Is_Enabled): New routine. (Variable_Has_Enabled_Property): Reimplement the detection of an enabled external property. Index: sem_prag.adb === --- sem_prag.adb(revision 213211) +++ sem_prag.adb(working copy) @@ -1834,29 +1834,28 @@ (N: Node_Id; Expr_Val : out Boolean) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - Obj : constant Node_Id := Get_Pragma_Arg (Arg1); - Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); + Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); begin Error_Msg_Name_1 := Pragma_Name (N); - -- The Async / Effective pragmas must apply to a volatile object other - -- than a formal subprogram parameter (SPARK RM 7.1.3(2)). + -- An external property pragma must apply to a volatile object other + -- than a formal subprogram parameter (SPARK RM 7.1.3(2)). The check + -- is performed at the end of the declarative region due to a possible + -- out-of-order arrangement of pragmas: + -- + --Obj : ...; + --pragma Async_Readers (Obj); + --pragma Volatile (Obj); - if Is_SPARK_Volatile_Object (Obj) then - if Is_Entity_Name (Obj) - and then Present (Entity (Obj)) - and then Is_Formal (Entity (Obj)) - then -SPARK_Msg_N (external property % cannot apply to parameter, N); - end if; - else + if not Is_SPARK_Volatile (Obj_Id) then SPARK_Msg_N (external property % must apply to a volatile object, N); end if; - -- Ensure that the expression (if present) is static Boolean. A missing + -- Ensure that the Boolean expression (if present) is static. A missing -- argument defaults the value
[Ada] Add query function to distinguish code of inlining from instances
In GNATprove, we need to distinguish code form inlined subprograms and code from generic instances, based on their source locations, to have better messages. This new query does precisely this. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Yannick Moy m...@adacore.com * sinput.ads, sinput.adb (Comes_From_Inlined_Body): New function that returns True for source pointer for an inlined body. Index: sinput.adb === --- sinput.adb (revision 213201) +++ sinput.adb (working copy) @@ -302,6 +302,17 @@ end case; end Check_For_BOM; + - + -- Comes_From_Inlined_Body -- + - + + function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is + SIE : Source_File_Record renames +Source_File.Table (Get_Source_File_Index (S)); + begin + return SIE.Inlined_Body; + end Comes_From_Inlined_Body; + --- -- Get_Column_Number -- --- Index: sinput.ads === --- sinput.ads (revision 213201) +++ sinput.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- -- @@ -638,6 +638,13 @@ -- value of the instantiation if this location is within an instance. -- If S is not within an instance, then this returns No_Location. + function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean; + pragma Inline (Comes_From_Inlined_Body); + -- Given a source pointer S, returns whether it comes from an inlined body. + -- This allows distinguishing these source pointers from those that come + -- from instantiation of generics, since Instantiation_Location returns a + -- valid location in both cases. + function Top_Level_Location (S : Source_Ptr) return Source_Ptr; -- Given a source pointer S, returns the argument unchanged if it is -- not in an instantiation. If S is in an instantiation, then it returns
[Ada] Front-end inlining in GNATprove mode
In GNATprove mode, all subprograms are candidates for front-end inlining, to simplify proofs. This patch extends this transformation to subprogam bodies that do not have a previous subprogram declaration. In this case the compiler builds a declaration, transfers aspects, if any, from body to declaration, and attempts to create a body_to_inline, as if the Inline_Always pragma was present on every such body. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Ed Schonberg schonb...@adacore.com * sem_ch6.adb (Hanalyze_Subprogram_Body_Helper): In GNATprove mode, subprogram bodies without a previous declaration are also candidates for front-end inlining. Index: sem_ch6.adb === --- sem_ch6.adb (revision 213240) +++ sem_ch6.adb (working copy) @@ -2952,6 +2952,42 @@ Spec_Id := Disambiguate_Spec; else Spec_Id := Find_Corresponding_Spec (N); + + -- In GNATprove mode, if the body has no previous spec, create + -- one so that the inlining machinery can operate properly. + -- Transfer aspects, if any, to the new spec, so that they + -- are legal and can be processed ahead of the body. + -- We make two copies of the given spec, one for the new + -- declaration, and one for the body. + + -- This cannot be done for a compilation unit, which is not + -- in a context where we can insert a new spec. + + if No (Spec_Id) + and then GNATprove_Mode + and then Debug_Flag_QQ + and then Full_Analysis + and then Comes_From_Source (Body_Id) + and then Is_List_Member (N) + then + declare + Body_Spec : constant Node_Id := + Copy_Separate_Tree (Specification (N)); + New_Decl : constant Node_Id := + Make_Subprogram_Declaration +(Loc, Copy_Separate_Tree (Specification (N))); + + begin + Insert_Before (N, New_Decl); + Move_Aspects (From = N, To = New_Decl); + Analyze (New_Decl); + Spec_Id := Defining_Entity (New_Decl); + + Set_Specification (N, Body_Spec); + Body_Id := Analyze_Subprogram_Specification (Body_Spec); + Set_Corresponding_Spec (N, Spec_Id); + end; + end if; end if; -- If this is a duplicate body, no point in analyzing it
[Ada] SPARK 2014 aspects should not be delayed
This patch changes the categorization of SPARK 2014 aspects from delayed to non-delayed. These aspects are equivalent to source pragmas which appear after their related constructs. To deal with forward references, the generatd pragmas are stored in N_Contract nodes and later analyzed at the end of the declarative region containing the related construct. No test needed, no change in behavior. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Hristian Kirtchev kirtc...@adacore.com * aspects.ads Add a comment explaining why SPARK 2014 aspects are not delayed. Update the delay status of most SPARK 2014 aspects. * sem_ch13.adb (Analyze_Aspect_Specifications): Update all calls to Decorate_Aspect_And_Pragma and Insert_Delayed_Pragma to refert to Decorate and Insert_Pragma. Add various comments concerning the delay status of several SPARK 2014 aspects. The insertion of Refined_State now uses routine Insert_After_SPARK_Mode. (Decorate): New routine. (Decorate_Aspect_And_Pragma): Removed. (Insert_Delayed_Pragma): Removed. (Insert_Pragma): New routine. Index: aspects.ads === --- aspects.ads (revision 213242) +++ aspects.ads (revision 213243) @@ -543,6 +543,14 @@ -- information from the parent type, which must be frozen at that point -- (since freezing the derived type first freezes the parent type). + -- SPARK 2014 aspects do not follow the general delay mechanism as they + -- act as annotations and cannot modify the attributes of their related + -- constructs. To handle forward references in such aspects, the compiler + -- delays the analysis of their respective pragmas by collecting them in + -- N_Contract nodes. The pragmas are then analyzed at the end of the + -- declarative region which contains the related construct. For details, + -- see routines Analyze_xxx_In_Decl_Part. + -- The following shows which aspects are delayed. There are three cases: type Delay_Type is @@ -593,12 +601,10 @@ Aspect_Asynchronous = Always_Delay, Aspect_Attach_Handler = Always_Delay, Aspect_Constant_Indexing= Always_Delay, - Aspect_Contract_Cases = Always_Delay, Aspect_CPU = Always_Delay, Aspect_Default_Iterator = Always_Delay, Aspect_Default_Value= Always_Delay, Aspect_Default_Component_Value = Always_Delay, - Aspect_Depends = Always_Delay, Aspect_Discard_Names= Always_Delay, Aspect_Dispatching_Domain = Always_Delay, Aspect_Dynamic_Predicate= Always_Delay, @@ -607,15 +613,12 @@ Aspect_External_Tag = Always_Delay, Aspect_Export = Always_Delay, Aspect_Favor_Top_Level = Always_Delay, - Aspect_Global = Always_Delay, Aspect_Implicit_Dereference = Always_Delay, Aspect_Import = Always_Delay, Aspect_Independent = Always_Delay, Aspect_Independent_Components = Always_Delay, Aspect_Inline = Always_Delay, Aspect_Inline_Always= Always_Delay, - Aspect_Initial_Condition= Always_Delay, - Aspect_Initializes = Always_Delay, Aspect_Input= Always_Delay, Aspect_Interrupt_Handler= Always_Delay, Aspect_Interrupt_Priority = Always_Delay, @@ -639,9 +642,6 @@ Aspect_Pure = Always_Delay, Aspect_Pure_Function= Always_Delay, Aspect_Read = Always_Delay, - Aspect_Refined_Depends = Always_Delay, - Aspect_Refined_Global = Always_Delay, - Aspect_Refined_State= Always_Delay, Aspect_Relative_Deadline= Always_Delay, Aspect_Remote_Access_Type = Always_Delay, Aspect_Remote_Call_Interface= Always_Delay, @@ -671,13 +671,21 @@ Aspect_Annotate = Never_Delay, Aspect_Async_Readers= Never_Delay, Aspect_Async_Writers= Never_Delay, + Aspect_Contract_Cases = Never_Delay, Aspect_Convention = Never_Delay, + Aspect_Depends = Never_Delay, Aspect_Dimension= Never_Delay, Aspect_Dimension_System = Never_Delay, Aspect_Effective_Reads = Never_Delay, Aspect_Effective_Writes = Never_Delay, + Aspect_Global = Never_Delay, + Aspect_Initial_Condition=
[Ada] Implement compilation date and time output and functions
This patch causes the compiler to print the compilation time in
-gnatv or -gnatl mode (suppressible with debug flag -gnatd7).
It also provides new functions in GNAT.Source_Info to obtain
the compilation date and time (in a form compatible with the
use of the C macros __DATE__ and __TIME__.
Finally a new function System.OS_Lib.Current_Time_String is
introduced (and used by the compiler to implement the above).
The following test is compiled with -gnatl:
Compiling: ctime.adb
Source file time stamp: 2014-04-04 14:00:32
Compiled at: 2014-04-04 10:03:24
1. with Text_IO; use Text_IO;
2. with GNAT.Source_Info; use GNAT.Source_Info;
3. procedure Ctime is
4. begin
5.Put_Line (Compilation_Date);
6.Put_Line (Compilation_Time);
7. end;
When run, the output is:
Jul 30 2014
10:03:24
Note: by its very nature, the above test is not suitable as a standard
regression test since of course its output changes each time it is run.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-30 Robert Dewar de...@adacore.com
* debug.adb: Document that d7 suppresses compilation time output.
* errout.adb (Write_Header): Include compilation time in
header output.
* exp_intr.adb (Expand_Intrinsic_Call): Add
Compilation_Date/Compilation_Time (Expand_Source_Info): Expand
Compilation_Date/Compilation_Time.
* g-souinf.ads (Compilation_Date): New function
(Compilation_Time): New function.
* gnat1drv.adb (Gnat1drv): Set Opt.Compilation_Time.
* gnat_rm.texi (Compilation_Date): New function
(Compilation_Time): New function.
* opt.ads (Compilation_Time): New variable.
* s-os_lib.ads, s-os_lib.adb (Current_Time_String): New function.
* sem_intr.adb (Compilation_Date): New function.
(Compilation_Time): New function.
* snames.ads-tmpl (Name_Compilation_Date): New entry.
(Name_Compilation_Time): New entry.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 213242)
+++ gnat_rm.texi(working copy)
@@ -14637,6 +14637,8 @@
@menu
* Intrinsic Operators::
+* Compilation_Date::
+* Compilation_Time::
* Enclosing_Entity::
* Exception_Information::
* Exception_Message::
@@ -14694,12 +14696,34 @@
It is also possible to specify such operators for private types, if the
full views are appropriate arithmetic types.
+@node Compilation_Date
+@section Compilation_Date
+@cindex Compilation_Date
+@noindent
+This intrinsic subprogram is used in the implementation of the
+library package @code{GNAT.Source_Info}. The only useful use of the
+intrinsic import in this case is the one in this unit, so an
+application program should simply call the function
+@code{GNAT.Source_Info.Compilation_Date} to obtain the date of
+the current compilation (in local time format MMM DD ).
+
+@node Compilation_Time
+@section Compilation_Time
+@cindex Compilation_Time
+@noindent
+This intrinsic subprogram is used in the implementation of the
+library package @code{GNAT.Source_Info}. The only useful use of the
+intrinsic import in this case is the one in this unit, so an
+application program should simply call the function
+@code{GNAT.Source_Info.Compilation_Time} to obtain the time of
+the current compilation (in local time format HH:MM:SS).
+
@node Enclosing_Entity
@section Enclosing_Entity
@cindex Enclosing_Entity
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Source_Info}. The only useful use of the
+library package @code{GNAT.Source_Info}. The only useful use of the
intrinsic import in this case is the one in this unit, so an
application program should simply call the function
@code{GNAT.Source_Info.Enclosing_Entity} to obtain the name of
@@ -14710,7 +14734,7 @@
@cindex Exception_Information'
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package @code{GNAT.Current_Exception}. The only useful
use of the intrinsic import in this case is the one in this unit,
so an application program should simply call the function
@code{GNAT.Current_Exception.Exception_Information} to obtain
@@ -14721,7 +14745,7 @@
@cindex Exception_Message
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package @code{GNAT.Current_Exception}. The only useful
use of the intrinsic import in this case is the one in this unit,
so an application program should simply call the function
@code{GNAT.Current_Exception.Exception_Message} to obtain
@@ -14732,7 +14756,7 @@
@cindex Exception_Name
@noindent
This intrinsic subprogram is used in the implementation of the
-library routine @code{GNAT.Current_Exception}. The only useful
+library package
[Ada] Forbid the use of in attribute 'Update
This patch implements the following SPARK 2014 rule: 4.4.1 (1) - The box symbol, , may not appear in any expression appearing in an update expression. The patch also cleans up the analysis of attribute 'Update. -- Source -- -- box_update.ads package Box_Update with SPARK_Mode = On is type I is range 1 .. 5; type T1 is range 1 .. 10 with Default_Value = 5; type A1 is array (I) of T1; procedure Init1 (X : out A1); end Box_Update; -- box_update.adb package body Box_Update with SPARK_Mode = On is procedure Init1 (X : out A1) is T : constant A1 := A1'(1 = 6, others = ); begin X := T'Update(1 = ); end Init1; end Box_Update; -- Compilation and output -- $ gcc -c box_update.adb box_update.adb:5:23: default initialization not allowed in attribute Update Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-30 Hristian Kirtchev kirtc...@adacore.com * sem_attr.adb (Analyze_Array_Component_Update): New routine. (Analyze_Attribute): Major cleanup of attribute 'Update. The logic is now split into two distinct routines depending on the type of the prefix. The use of is now illegal in attribute 'Update. (Analyze_Record_Component_Update): New routine. (Check_Component_Reference): Removed. (Resolve_Attribute): Remove the return statement and ??? comment following the processing for attribute 'Update. As a result, the attribute now freezes its prefix. Index: sem_attr.adb === --- sem_attr.adb(revision 213212) +++ sem_attr.adb(working copy) @@ -6220,69 +6220,158 @@ when Attribute_Update = Update : declare + Common_Typ : Entity_Id; + -- The common type of a multiple component update for a record + Comps : Elist_Id := No_Elist; - Expr : Node_Id; + -- A list used in the resolution of a record update. It contains the + -- entities of all record components processed so far. - procedure Check_Component_Reference - (Comp : Entity_Id; -Typ : Entity_Id); - -- Comp is a record component (possibly a discriminant) and Typ is a - -- record type. Determine whether Comp is a legal component of Typ. - -- Emit an error if Comp mentions a discriminant or is not a unique - -- component reference in the update aggregate. + procedure Analyze_Array_Component_Update (Assoc : Node_Id); + -- Analyze and resolve array_component_association Assoc against the + -- index of array type P_Type. - --- - -- Check_Component_Reference -- - --- + procedure Analyze_Record_Component_Update (Comp : Node_Id); + -- Analyze and resolve record_component_association Comp against + -- record type P_Type. - procedure Check_Component_Reference - (Comp : Entity_Id; -Typ : Entity_Id) - is -Comp_Name : constant Name_Id := Chars (Comp); + + -- Analyze_Array_Component_Update -- + -function Is_Duplicate_Component return Boolean; --- Determine whether component Comp already appears in list Comps + procedure Analyze_Array_Component_Update (Assoc : Node_Id) is +Expr : Node_Id; +High : Node_Id; +Index : Node_Id; +Index_Typ : Entity_Id; +Low : Node_Id; - --- Is_Duplicate_Component -- - + begin +-- The current association contains a sequence of indexes denoting +-- an element of a multidimensional array: -function Is_Duplicate_Component return Boolean is - Comp_Elmt : Elmt_Id; +--(Index_1, ..., Index_N) -begin - if Present (Comps) then - Comp_Elmt := First_Elmt (Comps); - while Present (Comp_Elmt) loop - if Chars (Node (Comp_Elmt)) = Comp_Name then -return True; +-- Examine each individual index and resolve it against the proper +-- index type of the array. + +if Nkind (First (Choices (Assoc))) = N_Aggregate then + Expr := First (Choices (Assoc)); + while Present (Expr) loop + + -- The use of others is illegal (SPARK RM 4.4.1(12)) + + if Nkind (Expr) = N_Others_Choice then + Error_Attr + (others choice not allowed in
[Ada] Missing interface conversion in access type
The compiler silently skips the generation of code to perform the conversion of an access type whose designated type is a class-wide interface type, thus causing unexpected problems at runtime in dispatching calls to the target object. After this patch the following test compiles and executes without errors: package Lists is type List is interface; function Element (Self : access List) return Natural is abstract; end Lists; limited with Lists; package Types is type List_Access is access all Lists.List'Class; end Types; with Types; with Lists; with Ada.Finalization; package My_Lists is type My_List is new Ada.Finalization.Controlled and Lists.List with null record; type My_List_Access is access all My_List'Class; overriding function Element (Self : access My_List) return Natural is (2); end My_Lists; with My_Lists; with Types; procedure Test is X : My_Lists.My_List_Access := new My_Lists.My_List; Y : Types.List_Access := Types.List_Access (X); -- Test begin if Y.Element /= 2 then raise Program_Error; end if; end Test; Command: gnatmake main.adb; ./main No output Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Javier Miranda mira...@adacore.com * exp_ch4.adb (Expand_N_Type_Conversion): Add missing implicit conversion to force the displacement of the pointer to the object to reference the secondary dispatch table. Index: exp_ch4.adb === --- exp_ch4.adb (revision 217828) +++ exp_ch4.adb (working copy) @@ -10622,7 +10622,9 @@ -- Ada 2005 (AI-251): Handle interface type conversion -if Is_Interface (Actual_Op_Typ) then +if Is_Interface (Actual_Op_Typ) + or else Is_Interface (Actual_Targ_Typ) +then Expand_Interface_Conversion (N); goto Done; end if;
[Ada] Lift limitation of inter-unit inlining with generic packages
This change lifts the arbitrary limitation on the number of iterations that can be executed between loading of the inlined bodies and instantiation of the generic bodies of external units when inter-unit inlining is activated. It was previously limited to 1 but this may be not sufficient in some cases, which can result in pragma Inline_Always not being honored. The following code must compile quietly with -O -gnatn: with Q; use Q; package P is function F (Cal : Calendar) return Boolean; end P; package body P is function F (Cal : Calendar) return Boolean is begin return Pred (Cal); end; end P; with R; use R; package Q is type Calendar is new Object_Ref; type Root_Calendar is new Root_Object with record B : Boolean; end record; type Root_Calendar_Ptr is access all Root_Calendar'Class; function Pred (Cal : Calendar) return Boolean; pragma Inline (Pred); end Q; package body Q is function Get_Calendar is new Get_Object (Root_Calendar, Root_Calendar_Ptr); pragma Inline (Get_Calendar); function Pred (Cal : Calendar) return Boolean is Cal_Object : constant Root_Calendar_Ptr := Get_Calendar (Object_Ref (Cal)); begin return Cal_Object.B; end; end Q; with Ada.Finalization; package R is type Root_Object is new Ada.Finalization.Controlled with record Reference_Count : Natural; end record; type Object_Ref is private; type Root_Object_Ptr is access all Root_Object'Class; generic type Object () is abstract new Root_Object with private; type Object_Ptr is access all Object'Class; function Get_Object (Ref : in Object_Ref) return Object_Ptr; private type Object_Ref is new Ada.Finalization.Controlled with record Ptr : Root_Object_Ptr; end record; end R; package body R is function Get_Object (Ref : in Object_Ref) return Object_Ptr is begin return Object_Ptr (Ref.Ptr); end Get_Object; end R; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Eric Botcazou ebotca...@adacore.com * inline.adb (Analyze_Inlined_Bodies): Iterate between loading of the inlined bodies and instantiation of the generic bodies until no more bodies need to be loaded. Index: inline.adb === --- inline.adb (revision 217828) +++ inline.adb (working copy) @@ -774,16 +774,21 @@ end if; J := J + 1; - end loop; - -- The analysis of required bodies may have produced additional - -- generic instantiations. To obtain further inlining, we perform - -- another round of generic body instantiations. Establishing a - -- fully recursive loop between inlining and generic instantiations - -- is unlikely to yield more than this one additional pass. +if J Inlined_Bodies.Last then - Instantiate_Bodies; + -- The analysis of required bodies may have produced additional + -- generic instantiations. To obtain further inlining, we need + -- to perform another round of generic body instantiations. + Instantiate_Bodies; + + -- Symmetrically, the instantiation of required generic bodies + -- may have caused additional bodies to be inlined. To obtain + -- further inlining, we keep looping over the inlined bodies. +end if; + end loop; + -- The list of inlined subprograms is an overestimate, because it -- includes inlined functions called from functions that are compiled -- as part of an inlined package, but are not themselves called. An
[Ada] Fix costly call to Following_Address_Clause
This change makes is so that Following_Address_Clause is invoked only if this is really necessary from Analyze_Object_Declaration. This saves about 1% of the compilation time at low optimization levels. No functional changes. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Eric Botcazou ebotca...@adacore.com * sem_ch3.adb (Analyze_Object_Declaration): Swap a couple of tests in a condition so Following_Address_Clause is invoked only if need be. * exp_util.ads (Following_Address_Clause): Add small note. Index: sem_ch3.adb === --- sem_ch3.adb (revision 217828) +++ sem_ch3.adb (working copy) @@ -3648,8 +3648,13 @@ if Comes_From_Source (N) and then Expander_Active + and then Nkind (E) = N_Aggregate + + -- Note the importance of doing this the following test after the + -- N_Aggregate test to avoid inefficiencies from too many calls to + -- the function Following_Address_Clause which can be expensive. + and then Present (Following_Address_Clause (N)) - and then Nkind (E) = N_Aggregate then Set_Etype (E, T); Index: exp_util.ads === --- exp_util.ads(revision 217828) +++ exp_util.ads(working copy) @@ -507,6 +507,10 @@ -- current declarative part to look for an address clause for the object -- being declared, and returns the clause if one is found, returns -- Empty otherwise. + -- + -- Note: this function can be costly and must be invoked with special care. + -- Possibly we could introduce a flag at parse time indicating the presence + -- of an address clause to speed this up??? procedure Force_Evaluation (Exp : Node_Id;
[Ada] Handling of function calls to predefined operators in ASIS
An operator that is called in functional notation is rewritten as an operator so that its operands can be properly resolved. ASIS needs the semantic info to be available on the original node, so in ASIS mode the resolved operands are linked back to the original call. This patch takes into account that the call may have had named associations, using the standard operator arguments Left and Right. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Ed Schonberg schonb...@adacore.com * sem_res.adb (Make_Call_Into_Operator): In ASIS mode, propagate back the resolved operands to the original call node, taking into account that the original call may have named associations. Index: sem_res.adb === --- sem_res.adb (revision 217828) +++ sem_res.adb (working copy) @@ -1793,16 +1793,62 @@ and then Nkind (N) in N_Op and then Nkind (Original_Node (N)) = N_Function_Call then - if Is_Binary then -Rewrite (First (Parameter_Associations (Original_Node (N))), - Relocate_Node (Left_Opnd (N))); -Rewrite (Next (First (Parameter_Associations (Original_Node (N, - Relocate_Node (Right_Opnd (N))); - else -Rewrite (First (Parameter_Associations (Original_Node (N))), - Relocate_Node (Right_Opnd (N))); - end if; + declare +L : constant Node_Id := Left_Opnd (N); +R : constant Node_Id := Right_Opnd (N); +Old_First : constant Node_Id := + First (Parameter_Associations (Original_Node (N))); +Old_Sec : Node_Id; + + begin +if Is_Binary then + Old_Sec := Next (Old_First); + + -- If the original call has named associations, replace the + -- explicit actual parameter in the association with the proper + -- resolved operand. + + if Nkind (Old_First) = N_Parameter_Association then + if Chars (Selector_Name (Old_First)) = + Chars (First_Entity (Op_Id)) + then + Rewrite (Explicit_Actual_Parameter (Old_First), + Relocate_Node (L)); + else + Rewrite (Explicit_Actual_Parameter (Old_First), + Relocate_Node (R)); + end if; + + else + Rewrite (Old_First, Relocate_Node (L)); + end if; + + if Nkind (Old_Sec) = N_Parameter_Association then + if Chars (Selector_Name (Old_Sec)) = + Chars (First_Entity (Op_Id)) + then + Rewrite (Explicit_Actual_Parameter (Old_Sec), + Relocate_Node (L)); + else + Rewrite (Explicit_Actual_Parameter (Old_Sec), + Relocate_Node (R)); + end if; + + else + Rewrite (Old_Sec, Relocate_Node (R)); + end if; + +else + if Nkind (Old_First) = N_Parameter_Association then + Rewrite (Explicit_Actual_Parameter (Old_First), +Relocate_Node (R)); + else + Rewrite (Old_First, Relocate_Node (R)); + end if; +end if; + end; + Set_Parent (Original_Node (N), Parent (N)); end if; end Make_Call_Into_Operator;
[Ada] Improper assignment on indexing operation with implicit dereference
If the left-hand side of an assignment is an Ada 2012 generalized indexing with an implicit derenference, the compiler must verify that the type of the access discriminant that provides the implicit dereference is not an access_to_constant. Compiling ada_test.adb must yield: ada_test.adb:24:25: left hand side of assignment must be a variable ada_test.adb:25:04: left hand side of assignment must be a variable --- with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; procedure Ada_Test is type Obj is record A : aliased Integer; end record; type Obj_Access is access all Obj; type Accessor (Data : access constant Integer) is null record with Implicit_Dereference = Data; function Get_Int (This : Obj_Access) return Accessor is begin return Accessor'(Data = This.A'Access); end Get_Int; X : aliased Obj := (A = 11); X_Ptr : Obj_Access := X'Access; begin Get_Int (X_Ptr).Data.all := 33; -- Error Get_Int (X_Ptr) := 33;-- Error Put (X.A);-- Should never execute.. New_Line; end Ada_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Ed Schonberg schonb...@adacore.com * sem_util.adb (Is_Variable): For an Ada 2012 implicit dereference introduced for an indexing opertion, check that the type of the corresponding access discriminant is not an access to constant. Index: sem_util.adb === --- sem_util.adb(revision 217829) +++ sem_util.adb(working copy) @@ -12806,12 +12806,14 @@ Is_Variable_Prefix (Original_Node (Prefix (N))); -- in Ada 2012, the dereference may have been added for a type with - -- a declared implicit dereference aspect. + -- a declared implicit dereference aspect. Check that it is not an + -- access to constant. elsif Nkind (N) = N_Explicit_Dereference and then Present (Etype (Orig_Node)) and then Ada_Version = Ada_2012 and then Has_Implicit_Dereference (Etype (Orig_Node)) +and then not Is_Access_Constant (Etype (Prefix (N))) then return True;
[Ada] Rework win32_wait to behave more like the UNIX waitpid()
The following changes are importants:
- It is possible to have multiple tasks waiting for a child process
to terminate.
- When a child terminates, a single wait call will receive the
corresponding process id.
- A call to wait will handle new incoming child processes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-11-20 Pascal Obry o...@adacore.com
* initialize.c (ProcListCS): New extern variable (critical section).
(ProcListEvt): New extern variable (handle).
(__gnat_initialize)[Win32]: Initialize the ProcListCS critical
section object and the ProcListEvt event.
* final.c (__gnat_finalize)[Win32]: Properly finalize the
ProcListCS critical section and the ProcListEvt event.
* adaint.c (ProcListEvt): New Win32 event handle.
(EnterCS): New routine to enter the critical section when dealing with
child processes chain list.
(LeaveCS): As above to exit from the critical section.
(SignalListChanged): Routine to signal that the chain process list has
been updated.
(add_handle): Use EnterCS/LeaveCS, also call SignalListChanged when the
handle has been added.
(__gnat_win32_remove_handle): Use EnterCS/LeaveCS,
also call SignalListChanged if the handle has been found and removed.
(remove_handle): Routine removed, implementation merged with the above.
(win32_wait): Use EnterCS/LeaveCS for the critical section. Properly
copy the PID list locally to ensure that even if the list is updated
the local copy remains valid. Add into the hl (handle list) the
ProcListEvt handle. This handle is used to signal that a change has
been made into the process chain list. This is to ensure that a waiting
call can be resumed to take into account new processes. We also make
sure that if the handle was not found into the list we start over
the wait call. Indeed another concurrent call to win32_wait()
could already have handled this process.
Index: final.c
===
--- final.c (revision 217828)
+++ final.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * 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- *
@@ -40,11 +40,29 @@
at all, the intention is that this be replaced by system specific code
where finalization is required. */
+#if defined (__MINGW32__)
+#include mingw32.h
+#include windows.h
+
+extern CRITICAL_SECTION ProcListCS;
+extern HANDLE ProcListEvt;
+
void
__gnat_finalize (void)
{
+ /* delete critical section and event handle used for the
+ processes chain list */
+ DeleteCriticalSection(ProcListCS);
+ CloseHandle (ProcListEvt);
}
+#else
+void
+__gnat_finalize (void)
+{
+}
+#endif
+
#ifdef __cplusplus
}
#endif
Index: initialize.c
===
--- initialize.c(revision 217828)
+++ initialize.c(working copy)
@@ -74,6 +74,8 @@
extern int gnat_argc;
extern char **gnat_argv;
+extern CRITICAL_SECTION ProcListCS;
+extern HANDLE ProcListEvt;
#ifdef GNAT_UNICODE_SUPPORT
@@ -138,6 +140,11 @@
given that we have set Max_Digits etc with this in mind */
__gnat_init_float ();
+ /* Initialize the critical section and event handle for the win32_wait()
+ implementation, see adaint.c */
+ InitializeCriticalSection (ProcListCS);
+ ProcListEvt = CreateEvent (NULL, FALSE, FALSE, NULL);
+
#ifdef GNAT_UNICODE_SUPPORT
/* Set current code page for filenames handling. */
{
Index: adaint.c
===
--- adaint.c(revision 217836)
+++ adaint.c(working copy)
@@ -2311,21 +2311,30 @@
for locking and unlocking tasks since we do not support multiple
threads on this configuration (Cert run time on native Windows). */
-static void dummy (void)
+static void EnterCS (void) {}
+static void LeaveCS (void) {}
+static void SignalListChanged (void) {}
+
+#else
+
+CRITICAL_SECTION ProcListCS;
+HANDLE ProcListEvt;
+
+static void EnterCS (void)
{
+ EnterCriticalSection(ProcListCS);
}
-void (*Lock_Task) () = dummy;
-void (*Unlock_Task) () = dummy;
+static void LeaveCS (void)
+{
+ LeaveCriticalSection(ProcListCS);
+}
-#else
+static void SignalListChanged (void)
+{
+ SetEvent (ProcListEvt);
+}
-#define Lock_Task
[Ada] Attributes 'Old and 'Update must preserve the tag of their prefix
The patch modifies the expansion of attributes 'Old and 'Update to ensure that the tag of a tagged prefix is not modified as a result attribute evaluation. -- Source -- -- types.ads package Types is type Root is tagged record X : Integer; end record; procedure Show (R : Root); type Ext is new Root with record Y : Integer; end record; overriding procedure Show (R : Ext); end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Show (R : Root) is begin Put_Line ((root) X = R.X'Img); end Show; overriding procedure Show (R : Ext) is begin Put_Line ((ext) X = R.X'Img); Put_Line ((ext) Y = R.Y'Img); end Show; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is procedure Show_Me (R : Root) is Tmp : Root'Class := R; begin Show (Tmp); end Show_Me; procedure Wibble (R : Root) is begin Show_Me (R); Show_Me (R'Update (X = 5)); end Wibble; A : Ext; begin A.X := 0; A.Y := 1; Wibble (Root (A)); end Main; -- Compilation and output -- $ gnatmake -q main.adb $ ./main (ext) X = 0 (ext) Y = 1 (ext) X = 5 (ext) Y = 1 Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Hristian Kirtchev kirtc...@adacore.com * exp_attr.adb (Expand_N_Attribute_Reference, Expand_Update_Attribute): Preserve the tag of a prefix by offering a specific view of the class-wide version of the prefix. Index: exp_attr.adb === --- exp_attr.adb(revision 217828) +++ exp_attr.adb(working copy) @@ -1021,6 +1021,9 @@ Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Blk : Node_Id; + CW_Decl : Node_Id; + CW_Temp : Entity_Id; + CW_Typ: Entity_Id; Decls : List_Id; Installed : Boolean; Loc : Source_Ptr; @@ -1338,19 +1341,56 @@ -- Step 3: Create a constant to capture the value of the prefix at the -- entry point into the loop. - -- Generate: - --Temp : constant type of Pref := Pref; - Temp_Id := Make_Temporary (Loc, 'P'); - Temp_Decl := -Make_Object_Declaration (Loc, - Defining_Identifier = Temp_Id, - Constant_Present= True, - Object_Definition = New_Occurrence_Of (Typ, Loc), - Expression = Relocate_Node (Pref)); - Append_To (Decls, Temp_Decl); + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + if Is_Tagged_Type (Typ) then + + -- Generate: + --CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + CW_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier = CW_Temp, + Constant_Present= True, + Object_Definition = New_Occurrence_Of (CW_Typ, Loc), + Expression = + Convert_To (CW_Typ, Relocate_Node (Pref))); + Append_To (Decls, CW_Decl); + + -- Generate: + --Temp : Typ renames Typ (CW_Temp); + + Temp_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier = Temp_Id, + Subtype_Mark= New_Occurrence_Of (Typ, Loc), + Name= + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))); + Append_To (Decls, Temp_Decl); + + -- Non-tagged case + + else + CW_Decl := Empty; + + -- Generate: + --Temp : constant Typ := Pref; + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier = Temp_Id, + Constant_Present= True, + Object_Definition = New_Occurrence_Of (Typ, Loc), + Expression = Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + end if; + -- Step 4: Analyze all bits Installed := Current_Scope = Scope (Loop_Id); @@ -1374,6 +1414,10 @@ -- the declaration of the constant. else + if Present (CW_Decl) then +Analyze (CW_Decl); + end if; + Analyze (Temp_Decl); end if; @@ -4358,19 +4402,13 @@ - when Attribute_Old = Old : declare - Asn_Stm : Node_Id; + Typ : constant Entity_Id := Etype (N); + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Subp: Node_Id; Temp: Entity_Id; begin - Temp := Make_Temporary (Loc, 'T', Pref); - - -- Set the entity kind now in order to mark
[Ada] Interaction between 'Loop_Entry, 'Old, 'Update and Extensions_Visible
This patch the following SPARK rule (the part about 'Loop_Entry, 'Old, 'Update) If the Extensions_Visible aspect is False for a subprogram, then certain restrictions are imposed on the use of any parameter of the subprogram which is of a specific tagged type. Such a parameter shall not be converted to a class-wide type. Such a parameter shall not be passed as an actual parameter in a call to a subprogram whose Extensions_Visible aspect is True. These restrictions also apply to any parenthesized expression, qualified expression, or type conversion whose operand is subject to these restrictions, to any Old, Update, or Loop_Entry attribute_reference whose prefix is subject to these restrictions, and to any conditional expression having at least one dependent_expression which is subjec to these restrictions. -- Source -- -- test_loop_entry_old_update.adb procedure Test_Loop_Entry_Old_Update is -- Test that Extensions_Visible restrictions are enforced for -- Old, Update, and Loop_Entry attribute references. pragma Assertion_Policy (Check); package Pkg is type T is abstract tagged record Int1, Int2, Int3 : Integer; end record; function Is_Bodacious (X : T) return Boolean is abstract; end Pkg; use Pkg; procedure P1 (X : in out T) with Post = Is_Bodacious (T'Class (X'Old)), -- ERROR Extensions_Visible = False; procedure P1 (X : in out T) is begin null; end P1; procedure P2 (X : in out T) with Extensions_Visible = False; procedure P2 (X : in out T) is begin if Is_Bodacious (T'Class (X'Update (Int1 = 123))) then-- ERROR X.Int1 := 123; end if; end P2; procedure P3 (X : in out T) with Extensions_Visible = False; procedure P3 (X : in out T) is begin for I in 1 .. 10 loop X.Int1 := X.Int1 + 1; pragma Assert ((X.Int1 /= X.Int2) or else Is_Bodacious (T'Class (X'Loop_Entry))); -- ERROR end loop; end P3; procedure P4 (X : in out T; Y : T'Class) with Extensions_Visible = False; procedure P4 (X : in out T; Y : T'Class) is begin if Is_Bodacious (T'Class (T'(if X.Int1 = X.Int2 -- ERROR then X'Update (Int1 = X.Int1 + 1) else T (Y then X.Int1 := 456; end if; end P4; begin null; end Test_Loop_Entry_Old_Update; -- Compilation and output -- $ gcc -c test_loop_entry_old_update.adb test_loop_entry_old_update.adb:15:38: formal parameter with Extensions_Visible False cannot be converted to class-wide type test_loop_entry_old_update.adb:22:34: formal parameter with Extensions_Visible False cannot be converted to class-wide type test_loop_entry_old_update.adb:33:44: formal parameter with Extensions_Visible False cannot be converted to class-wide type test_loop_entry_old_update.adb:42:13: formal parameter with Extensions_Visible False cannot be converted to class-wide type Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Hristian Kirtchev kirtc...@adacore.com * sem_util.adb (Is_EVF_Expression): Include attributes 'Loop_Entry, 'Old and 'Update to the logic. Index: sem_util.adb === --- sem_util.adb(revision 217835) +++ sem_util.adb(working copy) @@ -10846,6 +10846,16 @@ N_Type_Conversion) then return Is_EVF_Expression (Expression (N)); + + -- Attributes 'Loop_Entry, 'Old and 'Update are an EVF expression when + -- their prefix denotes an EVF expression. + + elsif Nkind (N) = N_Attribute_Reference +and then Nam_In (Attribute_Name (N), Name_Loop_Entry, + Name_Old, + Name_Update) + then + return Is_EVF_Expression (Prefix (N)); end if; return False;
[Ada] Add missing SPARK_Mode aspects/pragmas on formal containers
While the library of formal maps/sets correctly set SPARK_Mode on spec (On) and private part / body (Off), it was not the case for lists and vectors, thus causing some errors in GNATprove when instantiating such formal containers because bodies contain non-SPARK features (e.g. access types in formal vectors). Now fixed, which requires for formal lists and vectors that they are instantiated at library level, as other formal containers. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Yannick Moy m...@adacore.com * a-cfdlli.adb, a-cfdlli.ads, a-cfinve.adb, a-cfinve.ads, * a-cofove.adb, a-cofove.ads: Mark spec as SPARK_Mode, and private part/body as SPARK_Mode Off. * a-cfhama.adb, a-cfhama.ads, a-cfhase.adb, a-cfhase.ads, * a-cforma.adb, a-cforma.ads, a-cforse.adb, a-cforse.ads: Use aspect instead of pragma for uniformity. Index: a-cfdlli.adb === --- a-cfdlli.adb(revision 217828) +++ a-cfdlli.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-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- -- @@ -27,7 +27,9 @@ with System; use type System.Address; -package body Ada.Containers.Formal_Doubly_Linked_Lists is +package body Ada.Containers.Formal_Doubly_Linked_Lists with + SPARK_Mode = Off +is --- -- Local Subprograms -- Index: a-cfdlli.ads === --- a-cfdlli.ads(revision 217828) +++ a-cfdlli.ads(working copy) @@ -61,9 +61,11 @@ with function = (Left, Right : Element_Type) return Boolean is ; -package Ada.Containers.Formal_Doubly_Linked_Lists is +package Ada.Containers.Formal_Doubly_Linked_Lists with + Pure, + SPARK_Mode +is pragma Annotate (GNATprove, External_Axiomatization); - pragma Pure; type List (Capacity : Count_Type) is private with Iterable = (First = First, @@ -337,6 +339,7 @@ -- scanned yet. private + pragma SPARK_Mode (Off); type Node_Type is record Prev: Count_Type'Base := -1; Index: a-cfhase.adb === --- a-cfhase.adb(revision 217828) +++ a-cfhase.adb(working copy) @@ -35,8 +35,9 @@ with System; use type System.Address; -package body Ada.Containers.Formal_Hashed_Sets is - pragma SPARK_Mode (Off); +package body Ada.Containers.Formal_Hashed_Sets with + SPARK_Mode = Off +is --- -- Local Subprograms -- Index: a-cfhase.ads === --- a-cfhase.ads(revision 217828) +++ a-cfhase.ads(working copy) @@ -67,10 +67,11 @@ with function = (Left, Right : Element_Type) return Boolean is ; -package Ada.Containers.Formal_Hashed_Sets is +package Ada.Containers.Formal_Hashed_Sets with + Pure, + SPARK_Mode +is pragma Annotate (GNATprove, External_Axiomatization); - pragma Pure; - pragma SPARK_Mode (On); type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable = (First = First, @@ -335,9 +336,10 @@ -- scanned yet. private - pragma Inline (Next); pragma SPARK_Mode (Off); + pragma Inline (Next); + type Node_Type is record Element : Element_Type; Index: a-cfinve.adb === --- a-cfinve.adb(revision 217828) +++ a-cfinve.adb(working copy) @@ -26,7 +26,9 @@ -- http://www.gnu.org/licenses/. -- -- -package body Ada.Containers.Formal_Indefinite_Vectors is +package body Ada.Containers.Formal_Indefinite_Vectors with + SPARK_Mode = Off +is function H (New_Item : Element_Type) return Holder renames To_Holder; function E (Container : Holder) return Element_Type renames Get; Index: a-cfinve.ads === --- a-cfinve.ads(revision 217828) +++ a-cfinve.ads(working copy) @@ -52,7 +52,9 @@ -- size, and heap allocation will be avoided. If False, the containers can -- grow via heap allocation. -package Ada.Containers.Formal_Indefinite_Vectors is +package
[Ada] Generate VC in GNATprove instead of error for empty range check
Range checks on empty ranges typically correspond to deactivated code based on a given configuration (say, dead code inside a loop over the empty range). In GNATprove mode, instead of issuing an error message (which would stop analysis), enable the range check so that GNATprove will issue a message if it cannot prove that the check is unreachable. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Yannick Moy m...@adacore.com * checks.adb (Apply_Scalar_Range_Check): In GNATprove mode, put a range check when an empty range is used, instead of an error message. * sinfo.ads Update comment on GNATprove mode. Index: sinfo.ads === --- sinfo.ads (revision 217828) +++ sinfo.ads (working copy) @@ -581,6 +581,12 @@ -- bounds are generated from an expression: Expand_Subtype_From_Expr -- should be noop. + --5. Errors (instead of warnings) are issued on compile-time known + -- constraint errors, except in a few selected cases where it should + -- be allowed to let analysis proceed (e.g. range checks on empty + -- ranges, typically in deactivated code based on a given + -- configuration). + --- -- Check Flag Fields -- --- Index: checks.adb === --- checks.adb (revision 217828) +++ checks.adb (working copy) @@ -2926,7 +2926,21 @@ -- since all possible values will raise CE). if Lov Hiv then - Bad_Value; + + -- In GNATprove mode, do not issue a message in that case + -- (which would be an error stopping analysis), as this + -- likely corresponds to deactivated code based on a + -- given configuration (say, dead code inside a loop over + -- the empty range). Instead, we enable the range check + -- so that GNATprove will issue a message if it cannot be + -- proved. + + if GNATprove_Mode then +Enable_Range_Check (Expr); + else +Bad_Value; + end if; + return; end if;
[Ada] Give error message if duplicate Linker_Section given
Like other similar pragmas, we should disallow duplicate pragma or aspect Linker_Section for non-overloadable entities (for the case of overloading, the pragma only applies to previous entities which do not have such a pragma). The following should compile with the given error: 1. package Pkg1 is 2.Var_Dyn : natural; 3.pragma Linker_Section (Var_Dyn, .data_dyn); 4.pragma Linker_Section (Var_Dyn, .data_dyn1); | Linker_Section already specified for Var_Dyn at line 3 5. end Pkg1; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Robert Dewar de...@adacore.com * sem_prag.adb (Analyze_Pragma, case Linker_Section): Detect duplicate Linker_Section. Index: sem_prag.adb === --- sem_prag.adb(revision 217838) +++ sem_prag.adb(working copy) @@ -16380,6 +16380,7 @@ when Pragma_Linker_Section = Linker_Section : declare Arg : Node_Id; Ent : Entity_Id; +LPE : Node_Id; begin GNAT_Pragma; @@ -16398,9 +16399,18 @@ case Ekind (Ent) is -- Objects (constants and variables) and types. For these cases - -- all we need to do is to set the Linker_Section_pragma field. + -- all we need to do is to set the Linker_Section_pragma field, + -- checking that we do not have a duplicate. when E_Constant | E_Variable | Type_Kind = + LPE := Linker_Section_Pragma (Ent); + + if Present (LPE) then + Error_Msg_Sloc := Sloc (LPE); + Error_Msg_NE + (Linker_Section already specified for #, Arg1, Ent); + end if; + Set_Linker_Section_Pragma (Ent, N); -- Subprograms
[Ada] gnat1: back end switch -G nnn (PR ada/47500)
On platform where the switch is allowed, the gcc driver, when called with -Gnnn (nnn is a non negative number) invokes the compiler (gnat1) with -G nnn. This patch skips the argument nnn after -G, so that it is not taken as a source file name. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Vincent Celier cel...@adacore.com PR ada/47500 * back_end.adb (Scan_Back_End_Switches): Skip switch -G and its argument. Index: back_end.adb === --- back_end.adb(revision 217828) +++ back_end.adb(working copy) @@ -232,9 +232,10 @@ Last : constant Natural := Switch_Last (Switch_Chars); begin - -- Skip -o or internal GCC switches together with their argument + -- Skip -o, -G or internal GCC switches together with their argument. if Switch_Chars (First .. Last) = o + or else Switch_Chars (First .. Last) = G or else Is_Internal_GCC_Switch (Switch_Chars) then Next_Arg := Next_Arg + 1;
[Ada] Spurious errors on extension aggregate for limited type
This patch fixes two errors in the handling of extension aggregates for limited types: Ancestor part of extension aggregate can itself be an extension aggregate as well as a function call that is rewritten as a reference. The following must compile quietly: gcc -c p2.adb gcc -c bugzilla.ads --- package body P1 is function Create return T1 is begin return (Length = 3); end Create; end P1; --- package P1 is type T1 is tagged limited private; function Create return T1; private type T1 (Length : Positive := 3) is tagged limited null record; end P1; --- with P1; package P2 is type T2 is limited new P1.T1 with null record; function Create return T2; end P2; --- package body P2 is function Create return T2 is begin return (P1.Create with null record); end Create; end P2; --- with Ada.Finalization; package Bugzilla is type T1 is limited new Ada.Finalization.Limited_Controlled with null record; type T2 is new T1 with null record; X : T2 := (T1 with null record); Z : T2 := (T1'(Ada.Finalization.Limited_Controlled with null record) with null record); end Bugzilla; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Ed Schonberg schonb...@adacore.com * sem_aggr.adb (Valid_Limited_Ancestor): Ancestor part of extension aggregate can itself be an extension aggregate, as well as a call that is rewritten as a reference. Index: sem_aggr.adb === --- sem_aggr.adb(revision 217828) +++ sem_aggr.adb(working copy) @@ -2663,12 +2663,19 @@ function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is begin - if Is_Entity_Name (Anc) - and then Is_Type (Entity (Anc)) + if Is_Entity_Name (Anc) and then Is_Type (Entity (Anc)) then +return True; + + -- The ancestor must be a call or an aggregate, but a call may + -- have been expanded into a temporary, so check original node. + + elsif Nkind_In (Anc, N_Aggregate, + N_Extension_Aggregate, + N_Function_Call) then return True; - elsif Nkind_In (Anc, N_Aggregate, N_Function_Call) then + elsif Nkind (Original_Node (Anc)) = N_Function_Call then return True; elsif Nkind (Anc) = N_Attribute_Reference
[Ada] Inter-unit inlining of expression functions with -gnatn1
This enables inter-unit inlining of expression functions with -gnatn1, or more simply with -O1/-O2 -gnatn. These functions are automatically candidates for inlining, but there were actually inlined across units only with -gnatn2, or more simply -O3 -gnatn. The following program must compile without warnings with -O -gnatn -Winline: with Q; use Q; procedure P (I : Integer) is begin if Process (I) /= 2 * I then raise Program_Error; end if; end; package Q is function Process (I : Integer) return Integer; pragma Inline (Process); end Q; with R; use R; package body Q is function Process (I : Integer) return Integer is begin return Process2 (I) + Process3 (I); end; end Q; package R is function Process2 (I : Integer) return Integer; function Process3 (I : Integer) return Integer is (I); private function Process2 (I : Integer) return Integer is (I); end R; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Eric Botcazou ebotca...@adacore.com * inline.adb (Add_Inlined_Subprogram): Insert all programs generated as a body or whose declaration was provided along with the body. Index: inline.adb === --- inline.adb (revision 217842) +++ inline.adb (working copy) @@ -454,6 +454,7 @@ procedure Add_Inlined_Subprogram (Index : Subp_Index) is E: constant Entity_Id := Inlined.Table (Index).Name; + Decl : constant Node_Id := Parent (Declaration_Node (E)); Pack : constant Entity_Id := Get_Code_Unit_Entity (E); procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id); @@ -486,14 +487,17 @@ begin -- If the subprogram is to be inlined, and if its unit is known to be -- inlined or is an instance whose body will be analyzed anyway or the - -- subprogram has been generated by the compiler, and if it is declared + -- subprogram was generated as a body by the compiler (for example an + -- initialization procedure) or its declaration was provided along with + -- the body (for example an expression function), and if it is declared -- at the library level not in the main unit, and if it can be inlined -- by the back-end, then insert it in the list of inlined subprograms. if Is_Inlined (E) and then (Is_Inlined (Pack) or else Is_Generic_Instance (Pack) - or else Is_Internal (E)) + or else Nkind (Decl) = N_Subprogram_Body + or else Present (Corresponding_Body (Decl))) and then not In_Main_Unit_Or_Subunit (E) and then not Is_Nested (E) and then not Has_Initialized_Type (E)
[Ada] Type conversion to String causes Constraint_Error
This patch modifies the mechanism which creates a subtype from an arbitrary expression. The mechanism now captures the bounds of all index constraints when the expression is of an array type. -- Source -- -- pack.ads with Ada.Finalization; use Ada.Finalization; package Pack is type Ctrl is new Controlled with record Flag : Boolean := False; end record; type New_String is new String; function Make_Ctrl return Ctrl; function Make_String (Val : String) return New_String; end Pack; -- pack.adb package body Pack is function Make_Ctrl return Ctrl is Result : Ctrl; begin return Result; end Make_Ctrl; function Make_String (Val : String) return New_String is begin return New_String (Val); end Make_String; end Pack; -- pack2.ads package Pack2 is procedure Reproduce; end Pack2; -- pack2.adb with Ada.Text_IO; use Ada.Text_IO; with Pack;use Pack; package body Pack2 is Str : constant New_String := Make_String (Hello); Ctr : constant Ctrl := Make_Ctrl; procedure Reproduce is begin Put_Line (String (Str)); end Reproduce; end Pack2; -- main.adb with Pack2; use Pack2; procedure Main is begin Reproduce; end Main; -- Compilation and output -- $ gnatmake -q main.adb $ ./main Hello Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Hristian Kirtchev kirtc...@adacore.com * exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of all index constracts when the expression is of an array type. Index: exp_util.adb === --- exp_util.adb(revision 217854) +++ exp_util.adb(working copy) @@ -6399,22 +6399,24 @@ (E : Node_Id; Unc_Typ : Entity_Id) return Node_Id is + List_Constr : constant List_Id:= New_List; Loc : constant Source_Ptr := Sloc (E); - List_Constr : constant List_Id:= New_List; D : Entity_Id; + Full_Exp: Node_Id; + Full_Subtyp : Entity_Id; + High_Bound : Entity_Id; + Index_Typ : Entity_Id; + Low_Bound : Entity_Id; + Priv_Subtyp : Entity_Id; + Utyp: Entity_Id; - Full_Subtyp : Entity_Id; - Priv_Subtyp : Entity_Id; - Utyp : Entity_Id; - Full_Exp : Node_Id; - begin if Is_Private_Type (Unc_Typ) and then Has_Unknown_Discriminants (Unc_Typ) then - -- Prepare the subtype completion, Go to base type to - -- find underlying type, because the type may be a generic - -- actual or an explicit subtype. + -- Prepare the subtype completion. Use the base type to find the + -- underlying type because the type may be a generic actual or an + -- explicit subtype. Utyp:= Underlying_Type (Base_Type (Unc_Typ)); Full_Subtyp := Make_Temporary (Loc, 'C'); @@ -6451,22 +6453,67 @@ return New_Occurrence_Of (Priv_Subtyp, Loc); elsif Is_Array_Type (Unc_Typ) then + Index_Typ := First_Index (Unc_Typ); for J in 1 .. Number_Dimensions (Unc_Typ) loop -Append_To (List_Constr, - Make_Range (Loc, -Low_Bound = + +-- Capture the bounds of each index constraint in case the context +-- is an object declaration of an unconstrained type initialized +-- by a function call: + +--Obj : Unconstr_Typ := Func_Call; + +-- This scenario requires secondary scope management and the index +-- constraint cannot depend on the temporary used to capture the +-- result of the function call. + +--SS_Mark; +--Temp : Unconstr_Typ_Ptr := Func_Call'reference; +--subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last); +--Obj : S := Temp.all; +--SS_Release; -- Temp is gone at this point, bounds of S are +-- -- non existent. + +-- The bounds are kept as variables rather than constants because +-- this prevents spurious optimizations down the line. + +-- Generate: +--Low_Bound : Base_Type (Index_Typ) := E'First (J); + +Low_Bound := Make_Temporary (Loc, 'B'); +Insert_Action (E, + Make_Object_Declaration (Loc, +Defining_Identifier = Low_Bound, +Object_Definition = + New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), +Expression = Make_Attribute_Reference (Loc, -Prefix = Duplicate_Subexpr_No_Checks (E), +Prefix = Duplicate_Subexpr_No_Checks (E), Attribute_Name = Name_First, -
[Ada] Debugging information for inlined predefined units
The compiler suppresses debugging information on predefined units that are inlined in the code, because stepping into run-time units often complicates debugging activity. We make an exception for calls that appear in the source, when the unit is part of the Ada hierarchy, to facilitate monitoring of storage management. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Ed Schonberg schonb...@adacore.com * exp_ch6.adb (Expand_Call, Inlined_Subprogram): Do not suppress debugging information for a call to a predefined unit, if the call comes from source and the unit is in the Ada hierarchy. Index: exp_ch6.adb === --- exp_ch6.adb (revision 217828) +++ exp_ch6.adb (working copy) @@ -3720,7 +3720,17 @@ (Unit_File_Name (Get_Source_Unit (Sloc (Subp and then In_Extended_Main_Source_Unit (N) then - Set_Needs_Debug_Info (Subp, False); + -- We make an exception for calls to the Ada hierarchy if call + -- comes from source, because some user applications need the + -- debugging information for such calls. + + if Comes_From_Source (Call_Node) + and then Name_Buffer (1 .. 2) = a- + then + null; + else + Set_Needs_Debug_Info (Subp, False); + end if; end if; -- Front end expansion of simple functions returning unconstrained
[Ada] Improvements to handling of unchecked union discriminants
This patch avoids issuing a warning for a missing component clause for a discriminant in an unchecked union, and also avoids printing a line for such a component in the -gnatR2 output. The following program: 1. with Interfaces; 2. procedure Test_Union is 3. type Test_Type (Flag : Boolean) is 4. record 5. case Flag is 6. when True = 7. Thing_1 : Interfaces.Unsigned_32; 8. when False = 9. Thing_2 : Interfaces.Unsigned_32; 10. end case; 11. end record 12. with Unchecked_Union; 13. for Test_Type use 14. record 15. Thing_1 at 0 range 0 .. 31; 16. Thing_2 at 0 range 0 .. 31; 17. end record; 18.pragma Unreferenced (Test_Type); 19. begin 20. null; 21. end Test_Union; compiles quietly with switches -gnatwa -gnatR2, and generates this representation output: Representation information for unit Test_Union (body) for Test_Type'Size use 32; for Test_Type'Alignment use 4; for Test_Type use record Thing_1 at 0 range 0 .. 31; Thing_2 at 0 range 0 .. 31; end record; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-11-20 Robert Dewar de...@adacore.com * repinfo.adb (List_Record_Info): Do not list discriminant in unchecked union. * sem_ch13.adb (Has_Good_Profile): Minor reformatting (Analyze_Stream_TSS_Definition): Minor reformatting (Analyze_Record_Representation_Clause): Do not issue warning for missing rep clause for discriminant in unchecked union. Index: repinfo.adb === --- repinfo.adb (revision 217828) +++ repinfo.adb (working copy) @@ -847,37 +847,49 @@ Comp := First_Component_Or_Discriminant (Ent); while Present (Comp) loop - Get_Decoded_Name_String (Chars (Comp)); - Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); - Cfbit := Component_Bit_Offset (Comp); + -- Skip discriminant in unchecked union (since it is not there!) - if Rep_Not_Constant (Cfbit) then -UI_Image_Length := 2; + if Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Ent) + then +null; + -- All other cases + else --- Complete annotation in case not done +Get_Decoded_Name_String (Chars (Comp)); +Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); -Set_Normalized_Position (Comp, Cfbit / SSU); -Set_Normalized_First_Bit (Comp, Cfbit mod SSU); +Cfbit := Component_Bit_Offset (Comp); -Sunit := Cfbit / SSU; -UI_Image (Sunit); - end if; +if Rep_Not_Constant (Cfbit) then + UI_Image_Length := 2; - -- If the record is not packed, then we know that all fields whose - -- position is not specified have a starting normalized bit position - -- of zero. +else + -- Complete annotation in case not done - if Unknown_Normalized_First_Bit (Comp) - and then not Is_Packed (Ent) - then -Set_Normalized_First_Bit (Comp, Uint_0); + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + + Sunit := Cfbit / SSU; + UI_Image (Sunit); +end if; + +-- If the record is not packed, then we know that all fields +-- whose position is not specified have a starting normalized +-- bit position of zero. + +if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) +then + Set_Normalized_First_Bit (Comp, Uint_0); +end if; + +Max_Suni_Length := + Natural'Max (Max_Suni_Length, UI_Image_Length); end if; - Max_Suni_Length := - Natural'Max (Max_Suni_Length, UI_Image_Length); - Next_Component_Or_Discriminant (Comp); end loop; @@ -885,6 +897,17 @@ Comp := First_Component_Or_Discriminant (Ent); while Present (Comp) loop + + -- Skip discriminant in unchecked union (since it is not there!) + + if Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Ent) + then +goto Continue; + end if; + + -- All other cases + declare Esiz : constant Uint := Esize (Comp); Bofs : constant Uint := Component_Bit_Offset (Comp); Index: sem_ch13.adb === --- sem_ch13.adb(revision 217857) +++ sem_ch13.adb(working copy) @@ -3555,7 +3555,7 @@ if Base_Type (Typ) = Base_Type (Ent) or else (Is_Class_Wide_Type (Typ)
[Ada] Source in multi-unit source has unique object file name
Two units, one in a multi-source file and one in another source with
the same base file name do not have the same object file name.
No error during processing of the following project file should be
reported:
project Prj is
package Naming is
for Spec (foo_bar) use foo_bar.ads at 2;
for Spec (foo_bar_types) use foo_bar.ads at 1;
for Body (foo_bar) use foo_bar.adb;
end Naming;
end Prj;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-11-20 Vincent Celier cel...@adacore.com
* prj-nmsc.adb (Check_Object): If a unit is in a multi-source
file, its object file is never the same as any other unit.
Index: prj-nmsc.adb
===
--- prj-nmsc.adb(revision 217874)
+++ prj-nmsc.adb(working copy)
@@ -2577,7 +2577,7 @@
Error_Msg_Name_1 := Lang_Index.Display_Name;
Error_Msg
(Data.Flags,
- ?no compiler specified for language %%
+ ?\no compiler specified for language %%
, ignoring all its sources,
No_Location, Project);
@@ -2604,7 +2604,7 @@
if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
Error_Msg
(Data.Flags,
- Spec_Suffix not specified for
+ \Spec_Suffix not specified for
Get_Name_String (Lang_Index.Name),
No_Location, Project);
end if;
@@ -2612,7 +2612,7 @@
if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
Error_Msg
(Data.Flags,
- Body_Suffix not specified for
+ \Body_Suffix not specified for
Get_Name_String (Lang_Index.Name),
No_Location, Project);
end if;
@@ -2630,7 +2630,7 @@
Error_Msg_Name_1 := Lang_Index.Display_Name;
Error_Msg
(Data.Flags,
- no suffixes specified for %%,
+ \no suffixes specified for %%,
No_Location, Project);
end if;
end if;
@@ -3770,7 +3770,7 @@
if Switches /= No_Array_Element then
Error_Msg
(Data.Flags,
- ?Linker switches not taken into account in library
+ ?\Linker switches not taken into account in library
projects,
No_Location, Project);
end if;
@@ -6793,7 +6793,7 @@
Error_Msg_Name_2 := Source.Unit.Name;
Error_Or_Warning
(Data.Flags, Data.Flags.Missing_Source_Files,
- source file %% for unit %% not found,
+ \source file %% for unit %% not found,
No_Location, Project.Project);
end if;
end if;
@@ -7789,7 +7789,7 @@
Error_Msg_File_1 := Source.File;
Error_Msg
(Data.Flags,
- { cannot be both excluded and an exception file name,
+ \{ cannot be both excluded and an exception file name,
No_Location, Project.Project);
end if;
@@ -7936,13 +7936,15 @@
if Source /= No_Source
and then Source.Replaced_By = No_Source
and then Source.Path /= Src.Path
+ and then Source.Index = 0
+ and then Src.Index = 0
and then Is_Extending (Src.Project, Source.Project)
then
Error_Msg_File_1 := Src.File;
Error_Msg_File_2 := Source.File;
Error_Msg
(Data.Flags,
- { and { have the same object file name,
+ \{ and { have the same object file name,
No_Location, Project.Project);
else
[Ada] PR ada/63931
Fixing version number according to new GCC naming scheme. PR ada/63931 * gnatvsn.ads (Library_Version): Switch to 5. Index: gnatvsn.ads === --- gnatvsn.ads (revision 217874) +++ gnatvsn.ads (working copy) @@ -82,7 +82,7 @@ -- Prefix generated by binder. If it is changed, be sure to change -- GNAT.Compiler_Version.Ver_Prefix as well. - Library_Version : constant String := 5.0; + Library_Version : constant String := 5; -- Library version. This value must be updated when the compiler -- version number Gnat_Static_Version_String is updated. --
[Ada] New internal primitive Is_Subprogram_Or_Generic_Subprogram
This is a minor internal cleanup, to introduce a new primitive Is_Subprogram_Or_Generic_Subprogram with the obvious meaning. No external effect, no test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Robert Dewar de...@adacore.com * sem_ch7.adb, einfo.adb, einfo.ads, sem_prag.adb, sem_ch12.adb, freeze.adb, sem_util.adb, sem_res.adb, exp_ch6.adb, exp_ch13.adb, sem_ch6.adb, sem_cat.adb, sem_disp.adb (Is_Subprogram_Or_Generic_Subprogram): New primitive. Use this primitive throughout where appropriate. Index: sem_ch7.adb === --- sem_ch7.adb (revision 216063) +++ sem_ch7.adb (working copy) @@ -2808,7 +2808,7 @@ -- Body required if subprogram - elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then + elsif Is_Subprogram_Or_Generic_Subprogram (P) then return True; -- Treat a block as requiring a body @@ -2937,7 +2937,7 @@ -- Body required if subprogram - elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then + elsif Is_Subprogram_Or_Generic_Subprogram (P) then Error_Msg_N (info: requires body (subprogram case)?Y?, P); -- Body required if generic parent has Elaborate_Body Index: einfo.adb === --- einfo.adb (revision 216063) +++ einfo.adb (working copy) @@ -1129,8 +1129,7 @@ E_Package_Body, E_Subprogram_Body, E_Variable) - or else Is_Generic_Subprogram (Id) - or else Is_Subprogram (Id)); + or else Is_Subprogram_Or_Generic_Subprogram (Id)); return Node34 (Id); end Contract; @@ -3405,6 +3404,13 @@ return Ekind (Id) in Subprogram_Kind; end Is_Subprogram; + function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is + begin + return Ekind (Id) in Subprogram_Kind + or else + Ekind (Id) in Generic_Subprogram_Kind; + end Is_Subprogram_Or_Generic_Subprogram; + function Is_Task_Type(Id : E) return B is begin return Ekind (Id) in Task_Kind; @@ -3593,15 +3599,14 @@ begin pragma Assert (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Generic_Package, - E_Package, - E_Package_Body, - E_Subprogram_Body, - E_Variable, - E_Void) - or else Is_Generic_Subprogram (Id) - or else Is_Subprogram (Id)); + E_Entry_Family, + E_Generic_Package, + E_Package, + E_Package_Body, + E_Subprogram_Body, + E_Variable, + E_Void) + or else Is_Subprogram_Or_Generic_Subprogram (Id)); Set_Node34 (Id, V); end Set_Contract; Index: einfo.ads === --- einfo.ads (revision 216063) +++ einfo.ads (working copy) @@ -2974,6 +2974,10 @@ -- Applies to all entities, true for function, procedure and operator -- entities. +--Is_Subprogram_Or_Generic_Subprogram +-- Applies to all entities, true for function procedure and operator +-- entities, and also for the corresponding generic entities. + --Is_Synchronized_Interface (synthesized) -- Defined in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized @@ -6964,6 +6968,7 @@ function Is_Scalar_Type (Id : E) return B; function Is_Signed_Integer_Type (Id : E) return B; function Is_Subprogram (Id : E) return B; + function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B; function Is_Task_Type(Id : E) return B; function Is_Type (Id : E) return B; @@ -8800,6 +8805,7 @@ pragma Inline (Is_Base_Type); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Packed_Array); + pragma Inline (Is_Subprogram_Or_Generic_Subprogram); pragma Inline (Is_Volatile); pragma Inline (Is_Wrapper_Package); pragma Inline (Known_RM_Size); Index: sem_prag.adb === --- sem_prag.adb(revision 216063) +++ sem_prag.adb(working copy) @@ -6736,10 +6736,9 @@ (dispatching subprogram# cannot use Stdcall convention!, Arg1); - -- Subprogram is allowed, but not a generic subprogram + -- Subprograms are not allowed - elsif not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) + elsif not Is_Subprogram_Or_Generic_Subprogram (E)
[Ada] Check for attempt to bind GNATprove files
If one or more objects is compiled in GNATprove mode (either by using
GNATprove directly, or by using -gnatd.F), then the ALI file is marked
and gnatbind will exit with a message as shown here. Given:
1. procedure linkdf is
2. begin
3.null;
4. end;
If we first compile this with
gcc -c linkdf.adb -gnatd.F
then we try to do a gnatmake, we get
error: one or more files compiled in GNATprove mode
gnatmake: *** bind failed.
Previously this was not detected and the linker bombed
with peculiar error messages.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-10 Robert Dewar de...@adacore.com
* ali.adb (Scan_ALI): Read and process new GP flag on ALI P line.
* ali.ads (GNATprove_Mode): New component in ALI table.
(GNATprove_Mode_Specified): New global.
* gnatbind.adb (Gnatbind): Give fatal error if any file compiled
in GNATProve mode.
* lib-writ.ads, lib-writ.adb (GP): New flag on P line for
GNATProve_Mode.
Index: lib-writ.adb
===
--- lib-writ.adb(revision 216063)
+++ lib-writ.adb(working copy)
@@ -1153,6 +1153,10 @@
end if;
end if;
+ if GNATprove_Mode then
+ Write_Info_Str ( GP);
+ end if;
+
if Partition_Elaboration_Policy /= ' ' then
Write_Info_Str ( E);
Write_Info_Char (Partition_Elaboration_Policy);
Index: lib-writ.ads
===
--- lib-writ.ads(revision 216063)
+++ lib-writ.ads(working copy)
@@ -192,6 +192,9 @@
-- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
+ -- GP Set if this compilation was done in GNATprove mode, either
+ -- from direct use of GNATprove, or from use of -gnatdF.
+
-- Lx A valid Locking_Policy pragma applies to all the units in
-- this file, where x is the first character (upper case) of
-- the policy name (e.g. 'C' for Ceiling_Locking).
@@ -200,7 +203,9 @@
-- were not compiled to produce an object. This can occur as a
-- result of the use of -gnatc, or if no object can be produced
-- (e.g. when a package spec is compiled instead of the body,
- -- or a subunit on its own).
+ -- or a subunit on its own). Note that in GNATprove mode, we
+ -- do produce an object. The object is not suitable for binding
+ -- and linking, but we do not set NO, instead we set GP.
-- NR No_Run_Time. Indicates that a pragma No_Run_Time applies
-- to all units in the file.
Index: ali.adb
===
--- ali.adb (revision 216063)
+++ ali.adb (working copy)
@@ -111,6 +111,7 @@
Locking_Policy_Specified := ' ';
No_Normalize_Scalars_Specified := False;
No_Object_Specified:= False;
+ GNATprove_Mode_Specified := False;
Normalize_Scalars_Specified:= False;
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
@@ -875,6 +876,7 @@
First_Sdep = No_Sdep_Id,
First_Specific_Dispatching = Specific_Dispatching.Last + 1,
First_Unit = No_Unit_Id,
+GNATprove_Mode = False,
Last_Interrupt_State = Interrupt_States.Last,
Last_Sdep= No_Sdep_Id,
Last_Specific_Dispatching= Specific_Dispatching.Last,
@@ -1089,6 +1091,13 @@
ALIs.Table (Id).Partition_Elaboration_Policy :=
Partition_Elaboration_Policy_Specified;
+-- Processing for GP
+
+elsif C = 'G' then
+ Checkc ('P');
+ GNATprove_Mode_Specified := True;
+ ALIs.Table (Id).GNATprove_Mode := True;
+
-- Processing for Lx
elsif C = 'L' then
Index: ali.ads
===
--- ali.ads (revision 216063)
+++ ali.ads (working copy)
@@ -176,6 +176,11 @@
-- always be set as well in this case. Not set if 'P' appears in
-- Ignore_Lines.
+ GNATprove_Mode : Boolean;
+ -- Set to True if ALI and object file produced in GNATprove_Mode as
+ -- signalled by GP appearing on the P line. Not set if 'P' appears in
+ -- Ignore_Lines.
+
No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines.
@@ -465,6 +470,9 @@
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration
[Ada] Issue errors on illegal contracts unless SPARK_Mode is Off
Illegal Global/Depends contracts should be flagged by frontend in code for which SPARK_Mode is not specified, as GNATprove relies on contracts being legal in those cases. The frontend should skip these errors only when SPARK_Mode is Off. Now fixed, as shown on the following example. Command: $ gcc -c notinspark.ads Output: --- 1. package Notinspark is 2. 3.function Get return Integer; 4. 5.procedure Set with 6. Global = (In_Out = Get); | global item must denote variable or state 7. 8. end Notinspark; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Yannick Moy m...@adacore.com * errout.adb (SPARK_Msg_N): Issue error unless SPARK_Mode is Off. Index: errout.adb === --- errout.adb (revision 216063) +++ errout.adb (working copy) @@ -3138,7 +3138,7 @@ procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is begin - if SPARK_Mode = On then + if SPARK_Mode /= Off then Error_Msg_N (Msg, N); end if; end SPARK_Msg_N;
[Ada] Loop parameter is a constant in an iterator over a formal container.
This patch enforces the same semantics for the handling of loop parameters in element iterators over formal containers, os those over formal containers: the loop parameter cannot be assigned to in user code. Compiling formal_test.adb must yield: formal_test.adb:15:07: assignment to loop parameter not allowed --- with Ada.Containers.Formal_Doubly_Linked_Lists; procedure Formal_Test is type E is range 1 .. 1000; package My_List is new Ada.Containers.Formal_Doubly_Linked_Lists (E); use My_List; Thing : My_List.List (10); C : Cursor; begin for I in 1 .. 10 loop Append (Thing, E (I)); end loop; for Element of Thing loop null; Element := Element * 3; -- ERROR end loop; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Ed Schonberg schonb...@adacore.com * exp_ch5.adb (Expand_Formal_Container_Element_Loop): Analyze declaration for loop parameter before rest of loop, and set entity kind to prevent assignments to it in the user code. * sem_ch3.adb (Analyze_Object_Contract): No contracts apply to the loop parameter in an element iteration over o formal container. Index: exp_ch5.adb === --- exp_ch5.adb (revision 216063) +++ exp_ch5.adb (working copy) @@ -2889,7 +2889,17 @@ Statements = New_List (New_Loop))); Rewrite (N, New_Loop); - Analyze (New_Loop); + + -- The loop parameter is declared by an object declaration, but within + -- the loop we must prevent user assignments to it, so we analyze the + -- declaration and reset the entity kind, before analyzing the rest of + -- the loop; + + Analyze (Elmt_Decl); + Set_Ekind (Defining_Identifier (Elmt_Decl), E_Loop_Parameter); + Set_Assignment_OK (Name (Elmt_Ref)); + + Analyze (N); end Expand_Formal_Container_Element_Loop; - Index: sem_ch3.adb === --- sem_ch3.adb (revision 216063) +++ sem_ch3.adb (working copy) @@ -3062,6 +3062,12 @@ Error_Msg_N (constant cannot be volatile, Obj_Id); end if; + -- The loop parameter in an element iterator over a formal container + -- is declared with an object declaration but no contracts apply. + + elsif Ekind (Obj_Id) = E_Loop_Parameter then + null; + else pragma Assert (Ekind (Obj_Id) = E_Variable); -- The following checks are only relevant when SPARK_Mode is on as
[Ada] Operator name returned by GNAT.Source_Info.Enclosing_Entity
The string returned by GNAT.Source_Info.Enclosing_Entity did not include
names of operators (e.g. **).
The following program:
1. with Text_IO; use Text_IO;
2. with GNAT.Source_Info; use GNAT.Source_Info;
3. procedure BadEE is
4.type R is new Boolean;
5.RV : R := True;
6.
7.function ** (X, Y : R) return String is
8.begin
9. return Enclosing_Entity;
10.end;
11. begin
12.Put_Line (RV ** RV);
13. end BadEE;
must output the string:
BadEE.**
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-10 Robert Dewar de...@adacore.com
* exp_intr.adb (Write_Entity_Name): Moved to outer level
(Write_Entity_Name): Properly handle operator names
(Expand_Source_Info): New procedure.
* exp_intr.ads (Add_Source_Info): New procedure.
Index: exp_intr.adb
===
--- exp_intr.adb(revision 216063)
+++ exp_intr.adb(working copy)
@@ -36,7 +36,6 @@
with Exp_Fixd; use Exp_Fixd;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Namet;use Namet;
with Nmake;use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
@@ -116,6 +115,96 @@
--Name_Compilation_Date - expand string with compilation date
--Name_Compilation_Time - expand string with compilation time
+ procedure Write_Entity_Name (E : Entity_Id);
+ -- Recursive procedure to construct string for qualified name of enclosing
+ -- program unit. The qualification stops at an enclosing scope has no
+ -- source name (block or loop). If entity is a subprogram instance, skip
+ -- enclosing wrapper package. The name is appended to the current contents
+ -- of Name_Buffer, incrementing Name_Len.
+
+ -
+ -- Add_Source_Info --
+ -
+
+ procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is
+ Ent : Entity_Id;
+
+ Save_NB : constant String := Name_Buffer (1 .. Name_Len);
+ Save_NL : constant Natural := Name_Len;
+ -- Save current Name_Buffer contents
+
+ begin
+ Name_Len := 0;
+
+ -- Line
+
+ case Nam is
+
+ when Name_Line =
+Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc)));
+
+ when Name_File =
+Get_Decoded_Name_String
+ (Reference_Name (Get_Source_File_Index (Loc)));
+
+ when Name_Source_Location =
+Build_Location_String (Loc);
+
+ when Name_Enclosing_Entity =
+
+-- Skip enclosing blocks to reach enclosing unit
+
+Ent := Current_Scope;
+while Present (Ent) loop
+ exit when Ekind (Ent) /= E_Block
+ and then Ekind (Ent) /= E_Loop;
+ Ent := Scope (Ent);
+end loop;
+
+-- Ent now points to the relevant defining entity
+
+Write_Entity_Name (Ent);
+
+ when Name_Compilation_Date =
+declare
+ subtype S13 is String (1 .. 3);
+ Months : constant array (1 .. 12) of S13 :=
+ (Jan, Feb, Mar, Apr, May, Jun,
+ Jul, Aug, Sep, Oct, Nov, Dec);
+
+ M1 : constant Character := Opt.Compilation_Time (6);
+ M2 : constant Character := Opt.Compilation_Time (7);
+
+ MM : constant Natural range 1 .. 12 :=
+ (Character'Pos (M1) - Character'Pos ('0')) * 10 +
+ (Character'Pos (M2) - Character'Pos ('0'));
+
+begin
+ -- Reformat ISO date into MMM DD (__DATE__) format
+
+ Name_Buffer (1 .. 3) := Months (MM);
+ Name_Buffer (4) := ' ';
+ Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
+ Name_Buffer (7) := ' ';
+ Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
+ Name_Len := 11;
+end;
+
+ when Name_Compilation_Time =
+Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
+Name_Len := 8;
+
+ when others =
+raise Program_Error;
+ end case;
+
+ -- Prepend original Name_Buffer contents
+
+ Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
+Name_Buffer (1 .. Name_Len);
+ Name_Buffer (1 .. Save_NL) := Save_NB;
+ end Add_Source_Info;
+
-
-- Expand_Binary_Operator_Call --
-
@@ -718,61 +807,6 @@
Loc : constant Source_Ptr := Sloc (N);
Ent : Entity_Id;
- procedure Write_Entity_Name (E : Entity_Id);
- -- Recursive procedure to construct string for qualified name of
- -- enclosing program unit. The qualification stops at an enclosing
- -- scope has no source name (block or loop). If entity is a subprogram
- -- instance, skip
[Ada] Implement new pragma Prefix_Exception_Messages
This implements a new configuration pragma pragma Prefix_Exception_Messages; which causes messages set using raise x with s to be prefixed by the expanded name of the enclosing entity if s is a string literal (if s is more complex, we assume the program is calculating exactly the message it wants). So for example, if we have the program: 1. pragma Prefix_Exception_Messages; 2. procedure Prefixem is 3.procedure Inner is 4.begin 5. raise Constraint_Error with explicit raise; 6.end; 7. begin 8.Inner; 9. end Prefixem; The output will be: raised CONSTRAINT_ERROR : Prefixem.Inner: explicit raise This mode is automatic for run-time library files, so a typical message from the runtime library which used to look like: raised GNAT.CALENDAR.TIME_IO.PICTURE_ERROR : null picture string now looks like: raised GNAT.CALENDAR.TIME_IO.PICTURE_ERROR : GNAT.Calendar.Time_IO.Image: null picture string In the case of instantiations of containers, you will get the full qualified name of the particular instantiation that is involved. For example, the following program: 1. with Ada.Containers.Ordered_Sets; 2. procedure NoElmt is 3.package Ordered_Integer_Sets is 4. new Ada.Containers.Ordered_Sets (Integer); 5.use Ordered_Integer_Sets; 6. begin 7.if No_Element No_Element then 8. null; 9.end if; 10. end; will output raised CONSTRAINT_ERROR : NoElmt.Ordered_Integer_Sets.: Left cursor equals No_Element This allows disambiguation of messages without reintroducing line numbers which are problematic for maintaining tests over different versions and targets. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Robert Dewar de...@adacore.com * exp_ch11.adb (Expand_N_Raise_Statement): Handle Prefix_Exception_Messages. * opt.adb: Handle new flags Prefix_Exception_Message[_Config]. * opt.ads: New flags Prefix_Exception_Message[_Config]. * par-prag.adb: New dummy entry for pragma Prefix_Exception_Messages. * snames.ads-tmpl: Add entries for new pragma Prefix_Exception_Messages. * sem_prag.adb: Implement new pragma Prefix_Exception_Messages * gnat_rm.texi: Document pragma Prefix_Exception_Messages. Index: exp_ch11.adb === --- exp_ch11.adb(revision 216063) +++ exp_ch11.adb(working copy) @@ -29,6 +29,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; +with Exp_Intr; use Exp_Intr; with Exp_Util; use Exp_Util; with Namet;use Namet; with Nlists; use Nlists; @@ -1565,6 +1566,22 @@ if Present (Expression (N)) then + -- Adjust message to deal with Prefix_Exception_Messages. We only + -- add the prefix to string literals, if the message is being + -- constructed, we assume it already deals with uniqueness. + + if Prefix_Exception_Messages + and then Nkind (Expression (N)) = N_String_Literal + then +Name_Len := 0; +Add_Source_Info (Loc, Name_Enclosing_Entity); +Add_Str_To_Name_Buffer (: ); +Add_String_To_Name_Buffer (Strval (Expression (N))); +Rewrite (Expression (N), + Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len))); +Analyze_And_Resolve (Expression (N), Standard_String); + end if; + -- Avoid passing exception-name'identity in runtimes in which this -- argument is not used. This avoids generating undefined references -- to these exceptions when compiling with no optimization Index: gnat_rm.texi === --- gnat_rm.texi(revision 216081) +++ gnat_rm.texi(working copy) @@ -227,6 +227,7 @@ * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: +* Pragma Prefix_Exception_Messages:: * Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: @@ -1096,6 +1097,7 @@ * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: +* Pragma Prefix_Exception_Messages:: * Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: @@ -5692,6 +5694,34 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. +@node Pragma Prefix_Exception_Messages +@unnumberedsec Pragma Prefix_Exception_Messages +@cindex Prefix_Exception_Messages +@cindex exception +@cindex Exception_Message +@findex Exceptions +@noindent +Syntax: + +@smallexample @c ada +pragma Prefix_Exception_Messages; +@end smallexample + +@noindent +This is an implementation-defined configuration pragma that affects the +behavior of raise statements with a message given as a static string +constant (typically a
[Ada] Spurious error on local instantiation of pure generic unit
This patch fixes an error in the legality checks of aspects that apply to library units: these aspects are legal on a local instantiation of a library-level generic unit that carries the aspect pure. The following must compile quietly: gcc -c my_buffer.adb --- package My_Buffer with Elaborate_Body is end My_Buffer; --- with Common.Gen_Circular_Buffer; package body My_Buffer is type Capacity_Count is range 0 .. 10; procedure Copy_Integer (From_Element : in Integer; To_Element :out Integer) is begin To_Element := From_Element; end Copy_Integer; package Buffer is new Common.Gen_Circular_Buffer (Capacity_Count = Capacity_Count, Capacity = 10, Element_Type = Integer, Copy_Element = Copy_Integer); end My_Buffer; --- package body Common.Gen_Circular_Buffer is procedure Initialize (Buffer : out Buffer_Type) is begin Buffer.Start_Index := Element_Index'First; Buffer.Count := 0; end Initialize; procedure Insert (Element : in Element_Type; Buffer : in out Buffer_Type) is End_Index : Element_Index; -- Index into the end of the buffer where Element is to be stored. begin if Element_Index'Last - Buffer.Start_Index = Buffer.Count then End_Index := Buffer.Start_Index + Buffer.Count; else End_Index := Element_Index'First + (Buffer.Count - ((Element_Index'Last - Buffer.Start_Index) + 1)); end if; Copy_Element (From_Element = Element, To_Element = Buffer.Elements (End_Index)); Buffer.Count := Buffer.Count + 1; end Insert; procedure Remove (Buffer : in out Buffer_Type; Element : out Element_Type) is begin Copy_Element (From_Element = Buffer.Elements (Buffer.Start_Index), To_Element = Element); Discard_First (Buffer); end Remove; procedure Discard_First (Buffer : in out Buffer_Type) is begin if Buffer.Start_Index = Element_Index'Last then Buffer.Start_Index := Element_Index'First; else Buffer.Start_Index := Buffer.Start_Index + 1; end if; Buffer.Count := Buffer.Count - 1; end Discard_First; function Capacity_Used (Buffer : in Buffer_Type) return Element_Count is begin return Buffer.Count; end Capacity_Used; end Common.Gen_Circular_Buffer; --- generic type Capacity_Count is range ; Capacity : Capacity_Count; type Element_Type is limited private; with procedure Copy_Element (From_Element : in Element_Type; To_Element : out Element_Type); package Common.Gen_Circular_Buffer with Pure is type Buffer_Type is limited private; type Element_Count is new Capacity_Count range 0 .. Capacity; procedure Initialize (Buffer : out Buffer_Type); procedure Insert (Element : in Element_Type; Buffer : in out Buffer_Type) with Pre = Capacity_Used (Buffer) Element_Count'Last; procedure Remove (Buffer : in out Buffer_Type; Element : out Element_Type) with Pre = Capacity_Used (Buffer) 0; procedure Discard_First (Buffer : in out Buffer_Type) with Pre = Capacity_Used (Buffer) 0; function Capacity_Used (Buffer : in Buffer_Type) return Element_Count; private subtype Element_Index is Element_Count range 1 .. Element_Count'Last; type Element_Array is array (Element_Index) of Element_Type; type Buffer_Type is record Start_Index : Element_Index; Count : Element_Count; Elements : Element_Array; -- Element storage. end record; end Common.Gen_Circular_Buffer; --- package Common with Pure is end Common; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Ed Schonberg schonb...@adacore.com * sem_ch13.adb (Analyze_Aspect_Specifications, Library_Unit_Aspects): Aspect specification is legal on a local instantiation of a library-level generic unit. Index: sem_ch13.adb === --- sem_ch13.adb(revision 216081) +++ sem_ch13.adb(working copy) @@ -3018,12 +3018,15 @@ -- of a package declaration, the pragma needs to be inserted -- in the list of declarations for the associated package. -- There is no issue of visibility delay for these aspects. + -- Aspect is legal on a local instantiation of a library- + -- level generic unit. if A_Id in Library_Unit_Aspects and then Nkind_In (N, N_Package_Declaration, N_Generic_Package_Declaration) and then Nkind (Parent (N)) /= N_Compilation_Unit +and then not Is_Generic_Instance (Defining_Entity (N)) then
[Ada] Ada2012 freeze rules for subprogram profiles
Ada05-019 specifies that freezing a subprogram does not automatically freeze the profile, i.e. the types of the formals and the return type. In particular an attribute reference 'Access and its relatives do not freeze the profile. Compiling bd.ads must yield: bd.ads:15:34: incorrect expression for READ attribute --- with Ada.Streams; package BD is type My_Big_Int is range 0 .. 1; type Write_Ptr is access procedure (Stream : not null access Ada.Streams.Root_Stream_Type'Class; A : in My_Big_Int'Base); procedure Good_Write6 (Stream : not null access Ada.Streams.Root_Stream_Type'Class; A : in My_Big_Int'Base); WPtr : Write_Ptr := Good_Write6'Access; -- Does not freeze My_Big_Int (AI05-0019-1). for My_Big_Int'Read use WPtr.all; -- ERROR: private type My_Priv (D : Integer) is null record; end BD; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-10 Ed Schonberg schonb...@adacore.com * freeze.adb (Freeze_Entity): Freezing a subprogram does not always freeze its profile. In particular, an attribute reference that takes the access type does not freeze the types of the formals. Index: freeze.adb === --- freeze.adb (revision 216089) +++ freeze.adb (working copy) @@ -4004,7 +4004,17 @@ -- any extra formal parameters are created since we now know -- whether the subprogram will use a foreign convention. -if not Is_Internal (E) then +-- In Ada 2012, freezing a subprogram does not always freeze +-- the corresponding profile (see AI05-019). An attribute +-- reference is not a freezing point of the profile. +-- Other constructs that should not freeze ??? + +if Ada_Version Ada_2005 + and then Nkind (N) = N_Attribute_Reference +then + null; + +elsif not Is_Internal (E) then declare F_Type: Entity_Id; R_Type: Entity_Id;
[Ada] Missing inheritance of pragma Default_Initial_Condition
This patch modifies the inheritance of all attributes related to pragma Default_Initial_Condition to account for a case where the full view of a private type derives from another private type. -- Source -- -- parent.ads package Parent is type Parent_Typ is private with Default_Initial_Condition = False; private type Parent_Typ is null record; end Parent; -- derivation.ads with Parent; use Parent; package Derivation is type Derivation_Typ is private; private type Derivation_Typ is new Parent_Typ; end Derivation; -- derivation_check.adb with Ada.Assertions; use Ada.Assertions; with Ada.Text_IO;use Ada.Text_IO; with Derivation; use Derivation; procedure Derivation_Check is begin declare Obj : Derivation_Typ; begin Put_Line (ERROR: Default_Initial_Condition not triggered); end; exception when Assertion_Error = Put_Line (OK); when others = Put_Line (ERROR: expected Assertion_Error); end Derivation_Check; -- Compilation and output -- $ gnatmake -q -gnata derivation_check.adb $ ./derivation_check OK Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Hristian Kirtchev kirtc...@adacore.com * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation of all attributes related to pragma Default_Initial_Condition. (Build_Derived_Type): Propagation of all attributes related to pragma Default_Initial_Condition. (Process_Full_View): Account for the case where the full view derives from another private type and propagate the attributes related to pragma Default_Initial_Condition to the private view. (Propagate_Default_Init_Cond_Attributes): New routine. * sem_util.adb: Alphabetize various routines. (Build_Default_Init_Cond_Call): Use an unchecked type conversion when calling the default initial condition procedure of a private type. (Build_Default_Init_Cond_Procedure_Declaration): Prevent the generation of multiple default initial condition procedures. Index: sem_ch3.adb === --- sem_ch3.adb (revision 216367) +++ sem_ch3.adb (working copy) @@ -650,6 +650,17 @@ -- present. If errors are found, error messages are posted, and the -- Real_Range_Specification of Def is reset to Empty. + procedure Propagate_Default_Init_Cond_Attributes + (From_Typ : Entity_Id; + To_Typ : Entity_Id; + Parent_To_Derivation : Boolean := False; + Private_To_Full_View : Boolean := False); + -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit + -- all attributes related to pragma Default_Initial_Condition from From_Typ + -- to To_Typ. Flag Parent_To_Derivation should be set when the context is + -- the creation of a derived type. Flag Private_To_Full_View should be set + -- when processing both views of a private type. + procedure Record_Type_Declaration (T: Entity_Id; N: Node_Id; @@ -8546,23 +8557,6 @@ end if; Check_Function_Writable_Actuals (N); - - -- Propagate the attributes related to pragma Default_Initial_Condition - -- from the parent type to the private extension. A derived type always - -- inherits the default initial condition flag from the parent type. If - -- the derived type carries its own Default_Initial_Condition pragma, - -- the flag is later reset in Analyze_Pragma. Note that both flags are - -- mutually exclusive. - - if Has_Inherited_Default_Init_Cond (Parent_Type) -or else Present (Get_Pragma - (Parent_Type, Pragma_Default_Initial_Condition)) - then - Set_Has_Inherited_Default_Init_Cond (Derived_Type); - - elsif Has_Default_Init_Cond (Parent_Type) then - Set_Has_Default_Init_Cond (Derived_Type); - end if; end Build_Derived_Record_Type; @@ -8680,6 +8674,18 @@ Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); end if; + -- Propagate the attributes related to pragma Default_Initial_Condition + -- from the parent type to the private extension. A derived type always + -- inherits the default initial condition flag from the parent type. If + -- the derived type carries its own Default_Initial_Condition pragma, + -- the flag is later reset in Analyze_Pragma. Note that both flags are + -- mutually exclusive. + + Propagate_Default_Init_Cond_Attributes +(From_Typ = Parent_Type, + To_Typ = Derived_Type, + Parent_To_Derivation = True); + -- If the parent type has delayed rep aspects, then mark the derived -- type as possibly inheriting a delayed rep aspect. @@ -10008,6 +10014,401 @@
[Ada] Ensure record type equality treated correctly for codepeer
This is an internal change that does not affect the compiler, but fixes a problem in which a record comparison was not properly expanded. The compiler back end handled this, but it blew up codepeer. No further test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Robert Dewar de...@adacore.com * exp_ch4.adb (Expand_N_Op_Eq): Make sure we deal with the implementation base type. * sinfo.ads: Add a note for N_Op_Eq and N_Op_Ne that record operands are always expanded out into component comparisons. Index: exp_ch4.adb === --- exp_ch4.adb (revision 216367) +++ exp_ch4.adb (working copy) @@ -7152,8 +7152,11 @@ return; end if; - Typl := Base_Type (Typl); + -- Now get the implementation base type (note that plain Base_Type here + -- might lead us back to the private type, which is not what we want!) + Typl := Implementation_Base_Type (Typl); + -- Equality between variant records results in a call to a routine -- that has conditional tests of the discriminant value(s), and hence -- violates the No_Implicit_Conditionals restriction. Index: sinfo.ads === --- sinfo.ads (revision 216367) +++ sinfo.ads (working copy) @@ -4246,6 +4246,11 @@ -- point operands if the Treat_Fixed_As_Integer flag is set and will -- thus treat these nodes in identical manner, ignoring small values. + -- Note on equality/inequality tests for records. In the expanded tree, + -- record comparisons are always expanded to be a series of component + -- comparisons, so the back end will never see an equality or inequality + -- operation with operands of a record type. + -- Note on overflow handling: When the overflow checking mode is set to -- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may -- be modified to use a larger type for the operands and result. In
[Ada] Make System.Atomic_Counters available to user applications
The system unit System.Atomic_Counters which provides an atomic
counter type, along with increment, decrement and test operations,
available to user programs.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-17 Robert Dewar de...@adacore.com
* gnat_rm.texi: Document System.Atomic_Counters.
* impunit.adb: Add System.Atomic_Counters (s-atocou.ads) to the
list of user- accessible units added as children of System.
* s-atocou.ads: Update comment.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 216367)
+++ gnat_rm.texi(working copy)
@@ -661,6 +661,7 @@
* Interfaces.VxWorks.IO (i-vxwoio.ads)::
* System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads)::
+* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.ads)::
* System.Multiprocessors.Dispatching_Domains (s-mudido.ads)::
@@ -19074,6 +19075,7 @@
* Interfaces.VxWorks.IO (i-vxwoio.ads)::
* System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads)::
+* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.ads)::
* System.Multiprocessors.Dispatching_Domains (s-mudido.ads)::
@@ -20585,6 +20587,18 @@
by an run-time assertion failure, as well as the routine that
is used internally to raise this assertion.
+@node System.Atomic_Counters (s-atocou.ads)
+@section @code{System.Atomic_Counters} (@file{s-atocou.ads})
+@cindex @code{System.Atomic_Counters} (@file{s-atocou.ads})
+
+@noindent
+This package provides the declaration of an atomic counter type,
+together with efficient routines (using hardware
+synchronization primitives) for incrementing, decrementing,
+and testing of these counters. This package is implemented
+on most targets, including all Alpha, ia64, PowerPC, SPARC V9,
+x86, and x86_64 platforms.
+
@node System.Memory (s-memory.ads)
@section @code{System.Memory} (@file{s-memory.ads})
@cindex @code{System.Memory} (@file{s-memory.ads})
Index: impunit.adb
===
--- impunit.adb (revision 216367)
+++ impunit.adb (working copy)
@@ -367,6 +367,7 @@
--
(s-addima, F), -- System.Address_Image
+(s-atocou, F), -- System.Atomic_Counters
(s-assert, F), -- System.Assertions
(s-diflio, F), -- System.Dim.Float_IO
(s-diinio, F), -- System.Dim.Integer_IO
Index: s-atocou.ads
===
--- s-atocou.ads(revision 216367)
+++ s-atocou.ads(working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -37,8 +37,6 @@
--- all x86 platforms
--- all x86_64 platforms
--- Why isn't this package available to application programs???
-
package System.Atomic_Counters is
pragma Preelaborate;
@@ -59,20 +57,19 @@
function Decrement (Item : in out Atomic_Counter) return Boolean;
pragma Inline_Always (Decrement);
- -- Decrements value of atomic counter, returns True when value reach zero.
+ -- Decrements value of atomic counter, returns True when value reach zero
function Is_One (Item : Atomic_Counter) return Boolean;
pragma Inline_Always (Is_One);
- -- Returns True when value of the atomic counter is one.
+ -- Returns True when value of the atomic counter is one
procedure Initialize (Item : out Atomic_Counter);
pragma Inline_Always (Initialize);
-- Initialize counter by setting its value to one. This subprogram is
- -- intended to be used in special cases when counter object can't be
+ -- intended to be used in special cases when the counter object cannot be
-- initialized in standard way.
private
-
type Unsigned_32 is mod 2 ** 32;
type Atomic_Counter is limited record
[Ada] String literal is allowed for pragma Warnings in Ada 83
Documentation change only, no further test required
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-17 Robert Dewar de...@adacore.com
* gnat_rm.texi: Document that string literal can be used for
pragma Warnings when operating in Ada 83 mode.
Index: gnat_rm.texi
===
--- gnat_rm.texi(revision 216371)
+++ gnat_rm.texi(working copy)
@@ -7829,6 +7829,9 @@
pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
REASON ::= Reason = STRING_LITERAL @{ STRING_LITERAL@}
+
+Note: in Ada 83 mode, a string literal may be used in place of
+a static string expression (which does not exist in Ada 83).
@end smallexample
@noindent
[Ada] Class-wide type invariants for type extensions in other units.
A class-wide type invariant is inherited by a type extension, and incorporated into the invariant procedure for that type. When the expression for such an invariant (typically a function call) is first analyzed, we must preserve some semantic information in it, because the type extension may be declared in a different unit, where it cannot be resolved by visibility if it refers to local entities. The following must compile quietly: gcc -c -gnata inv2.ads --- package Inv1 is type T_Inv1 is tagged private with Type_Invariant'Class = Invariant (T_Inv1); function Invariant (This : in T_Inv1'Class) return Boolean; type T_Inv2 is new Inv1.T_Inv1 with private; private type T_Inv1 is tagged record Value : Integer := 1234; end record; function Invariant (This : in T_Inv1'Class) return Boolean is (This.Value 1000); type T_Inv2 is new Inv1.T_Inv1 with null record; end Inv1; --- with Inv1; package Inv2 is type T_Inv2 is new Inv1.T_Inv1 with private; private type T_Inv2 is new Inv1.T_Inv1 with null record; end Inv2; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Ed Schonberg schonb...@adacore.com * sem_ch13.adb (Add_Invariants): For a class-wide type invariant, preserve semantic information on the invariant expression (typically a function call) because it may be inherited by a type extension in a different unit, and it cannot be resolved by visibility elsewhere because it may refer to local entities. Index: sem_ch13.adb === --- sem_ch13.adb(revision 216367) +++ sem_ch13.adb(working copy) @@ -2947,8 +2947,7 @@ -- evaluation of this aspect should be delayed to the -- freeze point (why???) -if No (Expr) - or else Is_True (Static_Boolean (Expr)) +if No (Expr) or else Is_True (Static_Boolean (Expr)) then Set_Uses_Lock_Free (E); end if; @@ -3621,10 +3620,10 @@ if (Attr = Name_Constant_Indexing and then Present (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) - - or else (Attr = Name_Variable_Indexing -and then Present - (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) + or else + (Attr = Name_Variable_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) then if Debug_Flag_Dot_XX then null; @@ -4269,11 +4268,7 @@ -- Case of address clause for a (non-controlled) object -elsif - Ekind (U_Ent) = E_Variable -or else - Ekind (U_Ent) = E_Constant -then +elsif Ekind_In (U_Ent, E_Variable, E_Constant) then declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; @@ -4295,7 +4290,7 @@ if Present (O_Ent) and then (Has_Controlled_Component (Etype (O_Ent)) -or else Is_Controlled (Etype (O_Ent))) + or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N (??cannot overlay with controlled object, Expr); @@ -4826,13 +4821,10 @@ -- except from aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) -or else Is_Task_Type (U_Ent)) - then + if not Is_Concurrent_Type (U_Ent) then Error_Msg_N -(Interrupt_Priority can only be defined for task - and protected object, - Nam); +(Interrupt_Priority can only be defined for task + and protected object, Nam); elsif Duplicate_Clause then null; @@ -4985,14 +4977,12 @@ -- aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) -or else Is_Task_Type (U_Ent) + if not (Is_Concurrent_Type (U_Ent) or else Ekind (U_Ent) = E_Procedure) then Error_Msg_N -(Priority can only be defined for task and protected - object, - Nam); +(Priority can only be defined for task and protected + object, Nam); elsif Duplicate_Clause then
[Ada] Fix obscure case of compiler crash on bad attribute
This fixes an error in the handling of attributes where the prefix raises an exception. This resulted from other errors in the program. No simple test case has been found, but the correction is clearly safe. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Robert Dewar de...@adacore.com * sem_attr.adb (Eval_Attribute): Ensure that attribute reference is not marked as being a static expression if the prefix evaluation raises CE. Index: sem_attr.adb === --- sem_attr.adb(revision 216367) +++ sem_attr.adb(working copy) @@ -7553,15 +7553,17 @@ Static := Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); Set_Is_Static_Expression (N, Static); - end if; while Present (Nod) loop if not Is_Static_Subtype (Etype (Nod)) then Static := False; Set_Is_Static_Expression (N, False); + elsif not Is_OK_Static_Subtype (Etype (Nod)) then Set_Raises_Constraint_Error (N); + Static := False; + Set_Is_Static_Expression (N, False); end if; -- If however the index type is generic, or derived from @@ -7591,6 +7593,7 @@ begin E := E1; + while Present (E) loop -- If expression is not static, then the attribute reference @@ -7638,6 +7641,7 @@ end loop; if Raises_Constraint_Error (Prefix (N)) then +Set_Is_Static_Expression (N, False); return; end if; end;
[Ada] Better messages for missing entities in configurable runtime
A new mechanism has been implemented that allows specialization of error messages for missing entities in a configurable run-time. Instead of just outputting the (sometimes obscure) name of the entity involved, a more meaningful message can be issued. This new mechanism is used for a case of rendezvous not being supported and also for packed array operations not being supported. Also in the case of unsupported array packing, the message is now issued explicitly on the array type entity, as shown in this test program (compiled with -gnatld7 -gnatj55) 1. pragma No_Run_Time; 2. procedure BadPack (M : Integer) is 3.type R is mod 2 ** 43; 4.type A is array (1 .. 10) of R; | packing of 43-bit components not allowed in no run time mode 5.pragma Pack (A); 6.AV : A; 7. begin 8.AV (M) := 3; | construct not allowed in no run time mode packed component size of 43 is not supported 9. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Robert Dewar de...@adacore.com * exp_pakd.adb: Move bit packed entity tables to spec. * exp_pakd.ads: Move bit packed entity tables here from body. * freeze.adb (Freeze_Array_Type): Check that packed array type is supported. * rtsfind.adb (PRE_Id_Table): New table (Entity_Not_Defined): Specialize messages using PRE_Id_Table. * uintp.ads, uintp.adb (UI_Image): New functional form. Index: exp_pakd.adb === --- exp_pakd.adb(revision 216367) +++ exp_pakd.adb(working copy) @@ -34,7 +34,6 @@ with Nlists; use Nlists; with Nmake;use Nmake; with Opt; use Opt; -with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; @@ -77,365 +76,6 @@ -- right rotate into a left rotate, avoiding the subtract, if the machine -- architecture provides such an instruction. - -- - -- Entity Tables for Packed Access Routines -- - -- - - -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library - -- routines. This table provides the entity for the proper routine. - - type E_Array is array (Int range 01 .. 63) of RE_Id; - - -- Array of Bits_nn entities. Note that we do not use library routines - -- for the 8-bit and 16-bit cases, but we still fill in the table, using - -- entries from System.Unsigned, because we also use this table for - -- certain special unchecked conversions in the big-endian case. - - Bits_Id : constant E_Array := - (01 = RE_Bits_1, - 02 = RE_Bits_2, - 03 = RE_Bits_03, - 04 = RE_Bits_4, - 05 = RE_Bits_05, - 06 = RE_Bits_06, - 07 = RE_Bits_07, - 08 = RE_Unsigned_8, - 09 = RE_Bits_09, - 10 = RE_Bits_10, - 11 = RE_Bits_11, - 12 = RE_Bits_12, - 13 = RE_Bits_13, - 14 = RE_Bits_14, - 15 = RE_Bits_15, - 16 = RE_Unsigned_16, - 17 = RE_Bits_17, - 18 = RE_Bits_18, - 19 = RE_Bits_19, - 20 = RE_Bits_20, - 21 = RE_Bits_21, - 22 = RE_Bits_22, - 23 = RE_Bits_23, - 24 = RE_Bits_24, - 25 = RE_Bits_25, - 26 = RE_Bits_26, - 27 = RE_Bits_27, - 28 = RE_Bits_28, - 29 = RE_Bits_29, - 30 = RE_Bits_30, - 31 = RE_Bits_31, - 32 = RE_Unsigned_32, - 33 = RE_Bits_33, - 34 = RE_Bits_34, - 35 = RE_Bits_35, - 36 = RE_Bits_36, - 37 = RE_Bits_37, - 38 = RE_Bits_38, - 39 = RE_Bits_39, - 40 = RE_Bits_40, - 41 = RE_Bits_41, - 42 = RE_Bits_42, - 43 = RE_Bits_43, - 44 = RE_Bits_44, - 45 = RE_Bits_45, - 46 = RE_Bits_46, - 47 = RE_Bits_47, - 48 = RE_Bits_48, - 49 = RE_Bits_49, - 50 = RE_Bits_50, - 51 = RE_Bits_51, - 52 = RE_Bits_52, - 53 = RE_Bits_53, - 54 = RE_Bits_54, - 55 = RE_Bits_55, - 56 = RE_Bits_56, - 57 = RE_Bits_57, - 58 = RE_Bits_58, - 59 = RE_Bits_59, - 60 = RE_Bits_60, - 61 = RE_Bits_61, - 62 = RE_Bits_62, - 63 = RE_Bits_63); - - -- Array of Get routine entities. These are used to obtain an element from - -- a packed array. The N'th entry is used to obtain elements from a packed - -- array whose component size is N. RE_Null is used as a null entry, for - -- the cases where a library routine is not used. - - Get_Id : constant E_Array := - (01 = RE_Null, - 02 = RE_Null, - 03 = RE_Get_03, - 04 = RE_Null, - 05 = RE_Get_05, - 06 = RE_Get_06, - 07 = RE_Get_07, - 08 = RE_Null, - 09 = RE_Get_09, - 10 = RE_Get_10, - 11 = RE_Get_11, - 12 = RE_Get_12, - 13 = RE_Get_13, - 14 = RE_Get_14, - 15 = RE_Get_15, - 16 = RE_Null, -
[Ada] Short_Integer should be considered implementation defined
For the purposes of restriction No_Implementation_Identifiers, Standard.Short_Integer should be considered as being implementation defined and this was not the case. In addition, this patch fixes a compiler blow up with a compiler built with assertions in the test for implementation-defined identifiers. Note that the latter problem is not documented in the KP entry for this ticket, since it shows up only in compilers built with assertions. The following should compile as indicated with -gnatld7 -gnatj55 1. pragma Restriction_Warnings 2. (No_Implementation_Identifiers); 3. package ImplIdent is 4. subtype Integer_8 is Standard.Short_Short_Integer; | warning: violation of restriction No_Implementation_Identifiers at line 1 5. subtype Integer_16 is Standard.Short_Integer; | warning: violation of restriction No_Implementation_Identifiers at line 1 6. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Robert Dewar de...@adacore.com * cstand.adb (Create_Standard): Mark Short_Integer as implementation defined. * sem_util.adb (Set_Entity_With_Checks): Avoid blow up for compiler built with assertions for No_Implementation_Identifiers test. Index: sem_util.adb === --- sem_util.adb(revision 216371) +++ sem_util.adb(working copy) @@ -16462,8 +16462,9 @@ -- the entities within it). if (Is_Implementation_Defined (Val) - or else - Is_Implementation_Defined (Scope (Val))) + or else +(Present (Scope (Val)) + and then Is_Implementation_Defined (Scope (Val and then not (Ekind_In (Val, E_Package, E_Generic_Package) and then Is_Library_Level_Entity (Val)) then Index: cstand.adb === --- cstand.adb (revision 216367) +++ cstand.adb (working copy) @@ -735,6 +735,7 @@ Build_Signed_Integer_Type (Standard_Short_Integer, Standard_Short_Integer_Size); + Set_Is_Implementation_Defined (Standard_Short_Integer); Build_Signed_Integer_Type (Standard_Integer, Standard_Integer_Size);
[Ada] Better error message for illegal iterator expression
This patch improves the error message on an iterator specification whose name is a function call that does not yield a type that implements an iterator interface. Compiling try_containers.adb must yield: try_containers.adb:17:18: expect object that implements iterator interface -- with Ada.Text_Io; use Ada.Text_Io; with Ada.Containers.Vectors; procedure Try_Containers is package Integer_Vectors is new Ada.Containers.Vectors (Natural, Integer); use Integer_Vectors; A : Vector := To_Vector (1, 10); begin Loop_1 : for Element of A loop Put_Line (A (i) = Integer'Image (Element)); -- can't do Element := 2; end loop Loop_1; Loop_2 : for Cursor in First (A) loop -- oops! should be: -- for Cursor in Iterate (A) loop Put_Line (A (I) = Integer'Image (Element (Cursor))); Replace_Element (A, Cursor, 2); Reference (A, Cursor) := 2; end loop Loop_2; end Try_Containers; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Ed Schonberg schonb...@adacore.com * sem_ch5.adb (Analyze_Iterator_Specification): If the domain of iteration is given by an expression that is not an array type, verify that its type implements an iterator iterface. Index: sem_ch5.adb === --- sem_ch5.adb (revision 216367) +++ sem_ch5.adb (working copy) @@ -1838,6 +1838,17 @@ else Typ := Etype (Iter_Name); + + -- Verify that the expression produces an iterator. + + if not Of_Present (N) and then not Is_Iterator (Typ) + and then not Is_Array_Type (Typ) + and then No (Find_Aspect (Typ, Aspect_Iterable)) + then + Error_Msg_N +(expect object that implements iterator interface, +Iter_Name); + end if; end if; -- Protect against malformed iterator
[Ada] Directories are no longer created for abstract projects
Directories such as object directories are no longer created for abstract projects when the builder (gnatmake or gprbuild) is called with -P or with --subdirs=..., even when there is no explicit indication in the abstract project that there are no sources in the project. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Vincent Celier cel...@adacore.com * prj-nmsc.adb (Get_Directories): Do not create directories when a project is abstract. Index: prj-nmsc.adb === --- prj-nmsc.adb(revision 216367) +++ prj-nmsc.adb(working copy) @@ -5498,13 +5498,15 @@ Dir_Exists : Boolean; No_Sources : constant Boolean := - ((not Source_Files.Default + Project.Qualifier = Abstract_Project + or else + (((not Source_Files.Default and then Source_Files.Values = Nil_String) or else (not Source_Dirs.Default and then Source_Dirs.Values = Nil_String) or else (not Languages.Default and then Languages.Values = Nil_String)) - and then Project.Extends = No_Project; + and then Project.Extends = No_Project); -- Start of processing for Get_Directories
[Ada] Internal clean up (use Is_Directory_Separator)
This is an internal clean up to use an existing abstraction more extensively. No external effect, no test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Robert Dewar de...@adacore.com * gnatcmd.adb, make.adb, prj-part.adb, gnatlink.adb, prj-nmsc.adb, prj-conf.adb, prj-env.adb: Use Is_Directory_Separator where possible. Index: gnatcmd.adb === --- gnatcmd.adb (revision 216367) +++ gnatcmd.adb (working copy) @@ -883,10 +883,9 @@ if not Is_Absolute_Path (Exec_File_Name) then for Index in Exec_File_Name'Range loop if Exec_File_Name (Index) = Directory_Separator then - Fail (relative executable ( - Exec_File_Name - ) with directory part not allowed - when using project files); + Fail (relative executable ( Exec_File_Name + ) with directory part not allowed + when using project files); end if; end loop; @@ -1398,9 +1397,7 @@ else for K in Switch'Range loop -if Switch (K) = '/' - or else Switch (K) = Directory_Separator -then +if Is_Directory_Separator (Switch (K)) then Test_Existence := True; exit; end if; Index: make.adb === --- make.adb(revision 216367) +++ make.adb(working copy) @@ -4057,8 +4057,7 @@ begin First := Name'Last; while First Name'First -and then Name (First - 1) /= Directory_Separator -and then Name (First - 1) /= '/' +and then not Is_Directory_Separator (Name (First - 1)) loop First := First - 1; end loop; @@ -6805,8 +6804,7 @@ begin First := Name'Last; while First Name'First - and then Name (First - 1) /= Directory_Separator - and then Name (First - 1) /= '/' + and then not Is_Directory_Separator (Name (First - 1)) loop First := First - 1; end loop; Index: prj-part.adb === --- prj-part.adb(revision 216367) +++ prj-part.adb(working copy) @@ -349,8 +349,7 @@ Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); while Name_Len 0 -and then Name_Buffer (Name_Len) /= Directory_Separator -and then Name_Buffer (Name_Len) /= '/' +and then not Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; Index: gnatlink.adb === --- gnatlink.adb(revision 216367) +++ gnatlink.adb(working copy) @@ -1204,9 +1204,8 @@ if GCC_Index = 0 then GCC_Index := Index (Path (1 .. Path_Last), - Directory_Separator - lib - Directory_Separator); + Directory_Separator lib +Directory_Separator); end if; -- If we have found a lib subdir in Index: prj-nmsc.adb === --- prj-nmsc.adb(revision 216381) +++ prj-nmsc.adb(working copy) @@ -5031,10 +5031,7 @@ if OK then for J in 1 .. Name_Len loop - if Name_Buffer (J) = '/' - or else -Name_Buffer (J) = Directory_Separator - then + if Is_Directory_Separator (Name_Buffer (J)) then OK := False; exit; end if; @@ -5336,9 +5333,7 @@ function Compute_Directory_Last (Dir : String) return Natural is begin if Dir'Length 1 -and then (Dir (Dir'Last - 1) = Directory_Separator -or else - Dir (Dir'Last - 1) = '/') +and then Is_Directory_Separator (Dir (Dir'Last - 1)) then return Dir'Last - 1; else @@ -5858,7 +5853,7 @@ -- Check that there is no directory information for J in 1 .. Last loop - if Line (J) = '/' or else Line (J) = Directory_Separator then + if
[Ada] Spurious output on optimized default-initialized limited aggregate
When expanding a limited aggregate into individual assignments, we create a transient scope if the type of a component requires it. This must not be done if the context is an initialization procedure, because the target of the assignment must be visible outside of the block, and stack cleanup will happen on return from the initialization call. Otherwise this may result in dangling stack references in the back-end, which produce garbled results when compiled at higher optimization levels. Executing the following: gnatmake -q -O2 cutdown cutdown must yield: 0.0E+00 --- with Text_IO; use Text_IO; procedure Cutdown is type Angle_Object_T is tagged record M_Value : Float := 0.0; end record; Zero : constant Angle_Object_T := (M_Value = 0.0); type Platform_T is record M_Roll : Angle_Object_T := Zero; end record; package Observable_Nongeneric is type Writer_T is tagged limited record M_Value : Platform_T; end record; function Init (Value : in Platform_T) return Writer_T; end Observable_Nongeneric; package body Observable_Nongeneric is -- function Init (Value : in Platform_T) return Writer_T is begin return (M_Value = Value); end Init; -- end Observable_Nongeneric; type Object_T is tagged limited record M_Platform : aliased Observable_Nongeneric.Writer_T := Observable_Nongeneric.Init (Platform_T'(others = )); end record; Data : Object_T; begin Put_Line (Data.M_Platform.M_Value.M_Roll.M_Value'Img); if Data.M_Platform.M_Value.M_Roll.M_Value /= 0.0 then raise Program_Error; end if; end Cutdown; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-20 Ed Schonberg schonb...@adacore.com * exp_aggr.adb (Convert_To_Assignments): Do not create a transient scope for a component whose type requires it, if the context is an initialization procedure, because the target of the assignment must be visible outside of the block. Index: exp_aggr.adb === --- exp_aggr.adb(revision 216469) +++ exp_aggr.adb(working copy) @@ -3396,7 +3396,7 @@ -- that any finalization chain will be associated with that scope. -- For extended returns, we delay expansion to avoid the creation -- of an unwanted transient scope that could result in premature - -- finalization of the return object (which is built in in place + -- finalization of the return object (which is built in place -- within the caller's scope). or else @@ -3409,7 +3409,14 @@ return; end if; - if Requires_Transient_Scope (Typ) then + -- Otherwise, if a transient scope is required, create it now. If we + -- are within an initialization procedure do not create such, because + -- the target of the assignment must not be declared within a local + -- block, and because cleanup will take place on return from the + -- initialization procedure. + -- Should the condition be more restrictive ??? + + if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then Establish_Transient_Scope (N, Sec_Stack = Needs_Finalization (Typ)); end if;
[Ada] Aspect specifications and incomplete views
Typically an indexing aspect is specified on the private view of a tagged type. In the unusual case where there is an incomplete view and the aspect specification appears on the full view, the aspect specification must be analyzed on the full view rather than the incomplete one, to prevent freezing anomalies with the class-wide type, which otherwise might be frozen before the dispatch table for the type is constructed. Compiling and executing try2.adb must yield: ab --- pragma Ada_2012; with Ada.Text_IO; use Ada.Text_IO; procedure Try2 is package Pack is type T is tagged; function F (Obj : T; S : String; Pos : Positive) return Character; type T is tagged null record with Constant_Indexing = F; end Pack; package body Pack is function F (Obj : T; S : String; Pos : Positive) return Character is begin return S (Pos); end F; end Pack; use Pack; V : T; begin Put (V (abcd, 1)); Put (V (abcd, 2)); New_Line; end Try2; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-20 Ed Schonberg schonb...@adacore.com * sem_ch3.adb (Analyze_Full_Type_Declaration): If previous view is incomplete rather than private, and full type declaration has aspects, analyze aspects on the full view rather than the incomplete view, to prevent freezing anomalies with the class-wide type. Index: sem_ch3.adb === --- sem_ch3.adb (revision 216469) +++ sem_ch3.adb (working copy) @@ -2777,9 +2777,18 @@ -- them to the entity for the type which is currently the partial -- view, but which is the one that will be frozen. + -- In most cases the partial view is a private type, and both views + -- appear in different declarative parts. In the unusual case where the + -- partial view is incomplete, perform the analysis on the full view, + -- to prevent freezing anomalies with the corresponding class-wide type, + -- which otherwise might be frozen before the dispatch table is built. + if Has_Aspects (N) then - if Prev /= Def_Id then + if Prev /= Def_Id + and then Ekind (Prev) /= E_Incomplete_Type + then Analyze_Aspect_Specifications (N, Prev); + else Analyze_Aspect_Specifications (N, Def_Id); end if;
[Ada] Lift limitation on inter-unit inlining of instantiated subprograms
This change makes it so that instantiations of generic subprograms marked as inline are considered for inter-unit inlining. This was not previously the case because of a technical limitation that was too broadly enforced (unlike the associated comment which was more accurate) and excluded instantiations. The call to Q.Compare must be inlined if the code is compiled with -O -gnatn: with Q; function F (A, B : Integer) return Boolean is begin return Q.Compare (A, B); end; with G; package Q is function Compare is new G (Integer); end Q; generic type T is (); function G (Left,Right : T) return Boolean; pragma Inline (G); function G (Left,Right : T) return Boolean is begin return Left /= Right; end; 2014-10-20 Eric Botcazou ebotca...@adacore.com * inline.adb (List_Inlining_Info): Minor tweaks. (Add_Inlined_Body): Inline the enclosing package if it is not internally generated, even if it doesn't come from source. Index: inline.adb === --- inline.adb (revision 216469) +++ inline.adb (working copy) @@ -414,7 +414,7 @@ elsif Level = Inline_Package and then not Is_Inlined (Pack) - and then Comes_From_Source (E) + and then not Is_Internal (E) and then not In_Main_Unit_Or_Subunit (Pack) then Set_Is_Inlined (Pack); @@ -3888,7 +3888,7 @@ Count := Count + 1; if Count = 1 then - Write_Str (Listing of frontend inlined calls); + Write_Str (List of calls inlined by the frontend); Write_Eol; end if; @@ -3917,7 +3917,7 @@ Count := Count + 1; if Count = 1 then - Write_Str (Listing of inlined calls passed to the backend); + Write_Str (List of inlined calls passed to the backend); Write_Eol; end if; @@ -3947,7 +3947,7 @@ if Count = 1 then Write_Str - (Listing of inlined subprograms passed to the backend); + (List of inlined subprograms passed to the backend); Write_Eol; end if; @@ -3964,7 +3964,7 @@ end loop; end if; - -- Generate listing of subprogram that cannot be inlined by the backend + -- Generate listing of subprograms that cannot be inlined by the backend if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining @@ -3979,7 +3979,7 @@ if Count = 1 then Write_Str - (Listing of subprograms that cannot inline the backend); + (List of subprograms that cannot be inlined by the backend); Write_Eol; end if;
[Ada] Implement pragma/aspect No_Tagged_Streams
The No_Tagged_Streams pragma (and aspect) provides a method for selectively inhibiting the generation of stream routines for tagged types. It can be used either in a form naming a specific tagged type, or in a sequence of declarations to apply to all subsequent declarations. The following tests show the use of the pragma and the rejection of attempts to use stream operations on affected types. 1. with Ada.Text_IO; use Ada.Text_IO; 2. with Ada.Text_IO.Text_Streams; 3. use Ada.Text_IO.Text_Streams; 4. procedure NTS1 is 5.f : File_Type; 6.type R is tagged null record; 7.pragma No_Tagged_Streams (R); 8.RV : R; 9. begin 10.R'Write (Stream (f), RV); | no stream operations for R (No_Tagged_Streams at line 7) 11. end; 1. with Ada.Text_IO; use Ada.Text_IO; 2. with Ada.Text_IO.Text_Streams; 3. use Ada.Text_IO.Text_Streams; 4. procedure NTS2 is 5.pragma No_Tagged_Streams; 6.f : File_Type; 7.type R is tagged null record; 8.RV : R; 9. begin 10.R'Write (Stream (f), RV); | no stream operations for R (No_Tagged_Streams at line 5) 11. end; 1. with Ada.Text_IO; use Ada.Text_IO; 2. with Ada.Text_IO.Text_Streams; 3. use Ada.Text_IO.Text_Streams; 4. procedure NTS3 is 5.f : File_Type; 6.pragma No_Tagged_Streams; 7.type R is tagged null record; 8.RV : R; 9. begin 10.R'Write (Stream (f), RV); | no stream operations for R (No_Tagged_Streams at line 6) 11. end; 1. package NTS4 is 2.pragma No_Tagged_Streams; 3.type R is tagged null record; 4. end; 1. with Ada.Text_IO; use Ada.Text_IO; 2. with Ada.Text_IO.Text_Streams; 3. use Ada.Text_IO.Text_Streams; 4. with NTS4; use NTS4; 5. procedure NTS4M is 6.f : File_Type; 7.RV : R; 8. begin 9.R'Write (Stream (f), RV); | no stream operations for R (No_Tagged_Streams at nts4.ads:2) 10. end; 1. with Ada.Text_IO; use Ada.Text_IO; 2. with Ada.Text_IO.Text_Streams; 3. use Ada.Text_IO.Text_Streams; 4. procedure NTS5 is 5.f : File_Type; 6.type R is tagged null record 7. with No_Tagged_Streams = True; 8.type R1 is new R with 9. record F : Integer; end record; 10.RV : R1; 11. begin 12.R1'Write (Stream (f), RV); | no stream operations for R1 (No_Tagged_Streams at line 7) 13. end; The following test shows the rejection of incorrect usage 1. pragma No_Tagged_Streams; | pragma NO_TAGGED_STREAMS is not in declarative part or package spec 2. procedure NTS6 is 3.type R is new Integer; 4.pragma No_Tagged_Streams (Entity = R); | argument for pragma NO_TAGGED_STREAMS must be root tagged type 5. begin 6.null; 7. end; 2014-10-20 Robert Dewar de...@adacore.com * gnat_rm.texi: Document No_Tagged_Streams pragma and aspect. * snames.ads-tmpl: Add entry for pragma No_Tagged_Streams. * aspects.ads, aspects.adb: Add aspect No_Tagged_Streams. * einfo.adb (No_Tagged_Streams_Pragma): New field. * einfo.ads: Minor reformatting (reorder entries). (No_Tagged_Streams_Pragma): New field. * exp_ch3.adb: Minor comment update. * opt.ads (No_Tagged_Streams): New variable. * par-prag.adb: Add dummy entry for pragma No_Tagged_Streams. * sem.ads (Save_No_Tagged_Streams): New field in scope record. * sem_attr.adb (Check_Stream_Attribute): Check stream ops prohibited by No_Tagged_Streams. * sem_ch3.adb (Analyze_Full_Type_Declaration): Set No_Tagged_Streams_Pragma. (Analyze_Subtype_Declaration): ditto. (Build_Derived_Record_Type): ditto. (Record_Type_Declaration): ditto. * sem_ch8.adb (Pop_Scope): Restore No_Tagged_Streams. (Push_Scope): Save No_Tagged_Streams. * sem_prag.adb (Analyze_Pragma, case No_Tagged_Streams): Implement new pragma. Index: aspects.adb === --- aspects.adb (revision 216469) +++ aspects.adb (working copy) @@ -546,6 +546,7 @@ Aspect_Machine_Radix= Aspect_Machine_Radix, Aspect_No_Elaboration_Code_All = Aspect_No_Elaboration_Code_All, Aspect_No_Return= Aspect_No_Return, +Aspect_No_Tagged_Streams= Aspect_No_Tagged_Streams, Aspect_Obsolescent = Aspect_Obsolescent, Aspect_Object_Size = Aspect_Object_Size, Aspect_Output =
[Ada] Improve error recovery for bad comma/semicolon in expression
This patch improves the error recovery for an errant comma or semicolon after one condition in an expression when more conditions follow, as shown in this example: 1. procedure BadANDTHEN (X : Integer) is 2. begin 3.if X 10 4. and then X mod 4 = 2; | extra ; ignored 5. and then X mod 12 = 8 6.then 7. null; 8.end if; 9. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-20 Robert Dewar de...@adacore.com * par-ch4.adb (P_Expression): Handle extraneous comma/semicolon in middle of expression with logical operators. Index: par-ch4.adb === --- par-ch4.adb (revision 216469) +++ par-ch4.adb (working copy) @@ -1708,6 +1708,48 @@ Node1 := New_Op_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); + +-- Check for case of errant comma or semicolon + +if Token = Tok_Comma or else Token = Tok_Semicolon then + declare + Com: constant Boolean := Token = Tok_Comma; + Scan_State : Saved_Scan_State; + Logop : Node_Kind; + + begin + Save_Scan_State (Scan_State); -- at comma/semicolon + Scan; -- past comma/semicolon + + -- Check for AND THEN or OR ELSE after comma/semicolon. We + -- do not deal with AND/OR because those cases get mixed up + -- with the select alternatives case. + + if Token = Tok_And or else Token = Tok_Or then + Logop := P_Logical_Operator; + Restore_Scan_State (Scan_State); -- to comma/semicolon + + if Nkind_In (Logop, N_And_Then, N_Or_Else) then +Scan; -- past comma/semicolon + +if Com then + Error_Msg_SP -- CODEFIX + (|extra , ignored); +else + Error_Msg_SP -- CODEFIX + (|extra ; ignored); +end if; + + else +Restore_Scan_State (Scan_State); -- to comma/semicolon + end if; + + else + Restore_Scan_State (Scan_State); -- to comma/semicolon + end if; + end; +end if; + exit when Token not in Token_Class_Logop; end loop;
[Ada] Improve recognition of misspelled aspects
As shown by this example, the recognition of misspelled aspects is improved: 1. package UnrecogAs with Prelaborate is | Prelaborate is not a valid aspect identifier possible misspelling of Preelaborate 2.type R is tagged null record; 3. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-20 Robert Dewar de...@adacore.com * par-ch13.adb (Possible_Misspelled_Aspect): New function. Index: par-ch13.adb === --- par-ch13.adb(revision 216469) +++ par-ch13.adb(working copy) @@ -45,6 +45,26 @@ Scan_State : Saved_Scan_State; Result : Boolean; + function Possible_Misspelled_Aspect return Boolean; + -- Returns True, if Token_Name is a misspelling of some aspect name + + + -- Possible_Misspelled_Aspect -- + + + function Possible_Misspelled_Aspect return Boolean is + begin + for J in Aspect_Id_Exclude_No_Aspect loop +if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then + return True; +end if; + end loop; + + return False; + end Possible_Misspelled_Aspect; + + -- Start of processing for Aspect_Specifications_Present + begin -- Definitely must have WITH to consider aspect specs to be present @@ -74,17 +94,20 @@ if Token /= Tok_Identifier then Result := False; - -- This is where we pay attention to the Strict mode. Normally when we - -- are in Ada 2012 mode, Strict is False, and we consider that we have - -- an aspect specification if the identifier is an aspect name (even if - -- not followed by =) or the identifier is not an aspect name but is - -- followed by =, by a comma, or by a semicolon. The last two cases - -- correspond to (misspelled) Boolean aspects with a defaulted value of - -- True. P_Aspect_Specifications will generate messages if the aspect + -- This is where we pay attention to the Strict mode. Normally when + -- we are in Ada 2012 mode, Strict is False, and we consider that we + -- have an aspect specification if the identifier is an aspect name + -- or a likely misspelling of one (even if not followed by =) or + -- the identifier is not an aspect name but is followed by =, by + -- a comma, or by a semicolon. The last two cases correspond to + -- (misspelled) Boolean aspects with a defaulted value of True. + -- P_Aspect_Specifications will generate messages if the aspect -- specification is ill-formed. elsif not Strict then - if Get_Aspect_Id (Token_Name) /= No_Aspect then + if Get_Aspect_Id (Token_Name) /= No_Aspect + or else Possible_Misspelled_Aspect + then Result := True; else Scan; -- past identifier
