Re: [PATCH, Ada] RISC-V: Initial riscv linux Ada port.
On 07/08/2018 12:35 AM, Eric Botcazou wrote:
I haven't tried looking at the failures yet, and might not spend much
more time on this. Two of them are debug related, and debug support
is a work in progress. I need to finish the native riscv64-linux
support before we can do anything useful there, and I'd like to get
back to working on that as soon as possible.
No clue about debug11.adb, maybe Pierre-Marie could shed some light on it.
I don’t have much more to say than debug11.adb’s comment ;-)
This testcase checks that in the DWARF description of the variant type
below, the C discriminant is properly described as unsigned, hence the 0x5a
('Z') and 0x80 (128) values in the DW_AT_discr_list attribute. If it was
described as signed, we would have instead 90 and -128.
I don’t have an Ada RISC-V compiler (nor binutils) to check right now:
would it be possible to send the corresponding debug11.s and debug11.o?
Hopefully we just have to enhance the regexps.
--
Pierre-Marie de Rodat
Re: [PATCH, Ada] RISC-V: Initial riscv linux Ada port.
On 07/13/2018 01:57 AM, Jim Wilson wrote: I poked at this a little and noticed a difference between the x86_64 support and the RISC-V support. The RISC-V C language port has char as unsigned by default. The x86_64 port has char signed by default. If I add a -fsigned-char option, then the testcase works as expected for RISC-V. Curiously, the Ada compiler accepts -fsigned-char but not -funsigned-char. I tried hacking in a -funsigned-char flag, but when I use it with the x86_64 port the result is still correct. Maybe my quick hack wasn't quite right. Anyways, the default signedness of char has something to do with the problem. Ah, interesting! Last year, we installed specific code in the Ada front end and the DWARF back end to handle discrepancies between the INTEGER_TYPE signedness and the signedness to appear in debug info (https://gcc.gnu.org/git/?p=gcc.git;a=blob;f=gcc/dwarf2out.c;h=c2422e29658b6a101034318deed224271e6f1ca7;hb=HEAD#l24561), but ironically here, it seems that we don’t handle properly when everything is unsigned. I think the current testcase should work on RISC-V even without -fsigned-char: Character’s debug type should be unsigned in all cases. Maybe for some reason we don’t create the correct debug type in the Ada front end… Do you think I can reproduce this with a x86_64-linux compiler targetting something like riscv-elf? I don’t have access to a RISC-V board on which to build GCC. -- Pierre-Marie de Rodat
[Ada] Adjust growth factor from 1/32 to 1/2 for Unbounded_String
This will reduce significantly the number of allocations done when doing consecutive append operations. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Nicolas Roche gcc/ada/ * libgnat/a-strunb.adb, libgnat/a-strunb__shared.adb: Adjust growth factor from 1/32 to 1/2 for Unbounded_String.--- gcc/ada/libgnat/a-strunb.adb +++ gcc/ada/libgnat/a-strunb.adb @@ -763,13 +763,13 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; Chunk_Size : Natural) is - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc This causes --- gcc/ada/libgnat/a-strunb__shared.adb +++ gcc/ada/libgnat/a-strunb__shared.adb @@ -36,13 +36,13 @@ package body Ada.Strings.Unbounded is use Ada.Strings.Maps; - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
[Ada] Illegal deferred constant causes stack overflow
This patch prevents the compiler from entering infinite recursion when processing an illegal deferred constant. -- Source -- -- types.ads package Types is type Enum is (One, Two); end Types; -- types2.ads with Types; package Types2 is type Enum is private; One : constant Enum; Two : constant Enum; private type Enum is new Types.Enum; One : constant Enum := One; Two : constant Enum := Two; end Types2; -- Compilation and output -- $ gcc -c types2.ads types2.ads:10:04: full constant declaration appears too late types2.ads:11:04: full constant declaration appears too late Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Hristian Kirtchev gcc/ada/ * sem_eval.adb (Compile_Time_Known_Value): Add a guard which prevents the compiler from entering infinite recursion when trying to determine whether a deferred constant has a compile time known value, and the initialization expression of the constant is a reference to the constant itself.--- gcc/ada/sem_eval.adb +++ gcc/ada/sem_eval.adb @@ -1705,29 +1705,46 @@ package body Sem_Eval is end if; -- If we have an entity name, then see if it is the name of a constant - -- and if so, test the corresponding constant value, or the name of - -- an enumeration literal, which is always a constant. + -- and if so, test the corresponding constant value, or the name of an + -- enumeration literal, which is always a constant. if Present (Etype (Op)) and then Is_Entity_Name (Op) then declare -E : constant Entity_Id := Entity (Op); -V : Node_Id; +Ent : constant Entity_Id := Entity (Op); +Val : Node_Id; begin --- Never known at compile time if it is a packed array value. --- We might want to try to evaluate these at compile time one --- day, but we do not make that attempt now. +-- Never known at compile time if it is a packed array value. We +-- might want to try to evaluate these at compile time one day, +-- but we do not make that attempt now. if Is_Packed_Array_Impl_Type (Etype (Op)) then return False; -end if; -if Ekind (E) = E_Enumeration_Literal then +elsif Ekind (Ent) = E_Enumeration_Literal then return True; -elsif Ekind (E) = E_Constant then - V := Constant_Value (E); - return Present (V) and then Compile_Time_Known_Value (V); +elsif Ekind (Ent) = E_Constant then + Val := Constant_Value (Ent); + + if Present (Val) then + + -- Guard against an illegal deferred constant whose full + -- view is initialized with a reference to itself. Treat + -- this case as value not known at compile time. + + if Is_Entity_Name (Val) and then Entity (Val) = Ent then + return False; + else + return Compile_Time_Known_Value (Val); + end if; + + -- Otherwise the constant does not have a compile time known + -- value. + + else + return False; + end if; end if; end;
[Ada] Violation of No_Standard_Allocators_After_Elaboration not detected
The compiler fails to generate a call to detect allocators executed after elaboration in cases where the allocator is associated with Global_Pool_Object. The fix is to test for this associated storage pool as part of the condition for generating a call to System.Elaboration_Allocators.Check_Standard_Alloctor. Also, the exception Storage_Error is now generated instead of Program_Error for such a run-time violation, as required by the Ada RM in D.7. The following test must compile and execute quietly: -- Put the pragma in gnat.adc: pragma Restrictions (No_Standard_Allocators_After_Elaboration); package Pkg_With_Allocators is type Priv is private; procedure Allocate (Use_Global_Allocator : Boolean; During_Elaboration : Boolean); private type Rec is record Int : Integer; end record; type Priv is access Rec; end Pkg_With_Allocators; package body Pkg_With_Allocators is Ptr : Priv; procedure Allocate (Use_Global_Allocator : Boolean; During_Elaboration : Boolean) is type Local_Acc is access Rec; Local_Ptr : Local_Acc; begin if Use_Global_Allocator then Ptr := new Rec; -- Raise Storage_Error if after elaboration Ptr.Int := 1; else Local_Ptr := new Rec; -- Raise Storage_Error if after elaboration Local_Ptr.Int := 1; end if; if not During_Elaboration then raise Program_Error; -- No earlier exception: FAIL end if; exception when Storage_Error => if During_Elaboration then raise Program_Error; -- No exception expected: FAIL else null; -- Expected Storage_Error: PASS end if; when others => raise Program_Error; -- Unexpected exception: FAIL end Allocate; begin Allocate (Use_Global_Allocator => True, During_Elaboration => True); Allocate (Use_Global_Allocator => False, During_Elaboration => True); end Pkg_With_Allocators; with Pkg_With_Allocators; procedure Alloc_Restriction_Main is begin Pkg_With_Allocators.Allocate (Use_Global_Allocator => True, During_Elaboration => False); Pkg_With_Allocators.Allocate (Use_Global_Allocator => False, During_Elaboration => False); end Alloc_Restriction_Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Gary Dismukes gcc/ada/ * exp_ch4.adb (Expand_N_Allocator): Test for Storage_Pool being RTE in addition to the existing test for no Storage_Pool as a condition enabling generation of the call to Check_Standard_Allocator when the restriction No_Standard_Allocators_After_Elaboration is active. * libgnat/s-elaall.ads (Check_Standard_Allocator): Correct comment to say that Storage_Error will be raised (rather than Program_Error). * libgnat/s-elaall.adb (Check_Standard_Allocator): Raise Storage_Error rather than Program_Error when Elaboration_In_Progress is False.--- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -4561,12 +4561,14 @@ package body Exp_Ch4 is end if; end if; - -- If no storage pool has been specified and we have the restriction + -- If no storage pool has been specified, or the storage pool + -- is System.Pool_Global.Global_Pool_Object, and the restriction -- No_Standard_Allocators_After_Elaboration is present, then generate -- a call to Elaboration_Allocators.Check_Standard_Allocator. if Nkind (N) = N_Allocator -and then No (Storage_Pool (N)) +and then (No (Storage_Pool (N)) + or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object)) and then Restriction_Active (No_Standard_Allocators_After_Elaboration) then Insert_Action (N, --- gcc/ada/libgnat/s-elaall.adb +++ gcc/ada/libgnat/s-elaall.adb @@ -45,7 +45,7 @@ package body System.Elaboration_Allocators is procedure Check_Standard_Allocator is begin if not Elaboration_In_Progress then - raise Program_Error with + raise Storage_Error with "standard allocator after elaboration is complete is not allowed " & "(No_Standard_Allocators_After_Elaboration restriction active)"; end if; --- gcc/ada/libgnat/s-elaall.ads +++ gcc/ada/libgnat/s-elaall.ads @@ -51,7 +51,7 @@ package System.Elaboration_Allocators is procedure Check_Standard_Allocator; -- Called as part of every allocator in a program for which the restriction -- No_Standard_Allocators_After_Elaboration is active. This will raise an - -- exception (Program_Error with an appropriate message) if it is called + -- exception (Storage_Error with an appropriate message) if it is called -- after the call to Mark_End_Of_Elaboration. end System.Elaboration_Allocators;
[Ada] Adjust inlining in GNATprove mode for predicate/invariant/DIC
The frontend generates special functions for checking subtype predicates,
type invariants and Default_Initial_Condition aspect. These are translated
as predicates in GNATprove, and as such should no call inside these
functions should be inlined. This is similar to the existing handling of
calls inside expression functions.
There is no impact on compilation.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Yannick Moy
gcc/ada/
* sem_res.adb (Resolve_Call): Do not inline calls inside
compiler-generated functions translated as predicates in GNATprove.--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -5374,7 +5374,7 @@ package body Sem_Res is
-- A universal real conditional expression can appear in a fixed-type
-- context and must be resolved with that context to facilitate the
- -- code generation to the backend.
+ -- code generation in the back end.
elsif Nkind_In (N, N_Case_Expression, N_If_Expression)
and then Etype (N) = Universal_Real
@@ -6685,22 +6685,43 @@ package body Sem_Res is
elsif Full_Analysis then
- -- Do not inline calls inside expression functions, as this
+ -- Do not inline calls inside expression functions or functions
+ -- generated by the front end for subtype predicates, as this
-- would prevent interpreting them as logical formulas in
-- GNATprove. Only issue a message when the body has been seen,
-- otherwise this leads to spurious messages on callees that
-- are themselves expression functions.
if Present (Current_Subprogram)
- and then Is_Expression_Function_Or_Completion
-(Current_Subprogram)
+ and then
+ (Is_Expression_Function_Or_Completion (Current_Subprogram)
+ or else Is_Predicate_Function (Current_Subprogram)
+ or else Is_Invariant_Procedure (Current_Subprogram)
+ or else Is_DIC_Procedure (Current_Subprogram))
then
if Present (Body_Id)
and then Present (Body_To_Inline (Nam_Decl))
then
- Cannot_Inline
- ("cannot inline & (inside expression function)?",
-N, Nam_UA);
+ if Is_Predicate_Function (Current_Subprogram) then
+Cannot_Inline
+ ("cannot inline & (inside predicate)?",
+ N, Nam_UA);
+
+ elsif Is_Invariant_Procedure (Current_Subprogram) then
+Cannot_Inline
+ ("cannot inline & (inside invariant)?",
+ N, Nam_UA);
+
+ elsif Is_DIC_Procedure (Current_Subprogram) then
+Cannot_Inline
+("cannot inline & (inside Default_Initial_Condition)?",
+ N, Nam_UA);
+
+ else
+Cannot_Inline
+ ("cannot inline & (inside expression function)?",
+ N, Nam_UA);
+ end if;
end if;
-- With the one-pass inlining technique, a call cannot be
@@ -11854,7 +11875,7 @@ package body Sem_Res is
Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id));
-- Build bona fide subtype for the string, and wrap it in an
--- unchecked conversion, because the backend expects the
+-- unchecked conversion, because the back end expects the
-- String_Literal_Subtype to have a static lower bound.
Index_Subtype :=
@@ -11864,7 +11885,7 @@ package body Sem_Res is
Set_Parent (Drange, N);
Analyze_And_Resolve (Drange, Index_Type);
--- In the context, the Index_Type may already have a constraint,
+-- In this context, the Index_Type may already have a constraint,
-- so use common base type on string subtype. The base type may
-- be used when generating attributes of the string, for example
-- in the context of a slice assignment.
[Ada] Bit_Order cannot be defined for record extensions
This patch allows the compiler to report an error on Bit_Order when
defined for a record extension.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Report an error
on Bit_Order when defined for a record extension.
gcc/testsuite/
* gnat.dg/bit_order1.adb: New testcase.--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -5331,6 +5331,12 @@ package body Sem_Ch13 is
Error_Msg_N
("Bit_Order can only be defined for record type", Nam);
+elsif Is_Tagged_Type (U_Ent)
+ and then Is_Derived_Type (U_Ent)
+then
+ Error_Msg_N
+ ("Bit_Order cannot be defined for record extensions", Nam);
+
elsif Duplicate_Clause then
null;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bit_order1.adb
@@ -0,0 +1,18 @@
+-- { dg-do compile }
+
+with System;
+
+procedure Bit_Order1 is
+
+ type Sample_Ttype is tagged record
+ Data : Natural;
+ end record;
+
+ type Other_Type is new Sample_Ttype with record
+ Other_Data : String (1 .. 100);
+ end record;
+
+ for Other_Type'Bit_Order use System.High_Order_First; -- { dg-error "Bit_Order cannot be defined for record extensions" }
+begin
+ null;
+end;
[Ada] Crash processing sources under GNATprove debug mode
Processing sources under -gnatd.F the frontend may crash on
an iterator of the form 'for X of ...' over an array if the
iterator is located in an inlined subprogram.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Code cleanup. Required
to avoid generating an ill-formed tree that confuses gnatprove causing
it to blowup.
gcc/testsuite/
* gnat.dg/iter2.adb, gnat.dg/iter2.ads: New testcase.--- gcc/ada/exp_ch5.adb
+++ gcc/ada/exp_ch5.adb
@@ -3711,9 +3711,14 @@ package body Exp_Ch5 is
Ind_Comp :=
Make_Indexed_Component (Loc,
- Prefix => Relocate_Node (Array_Node),
+ Prefix => New_Copy_Tree (Array_Node),
Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
+ -- Propagate the original node to the copy since the analysis of the
+ -- following object renaming declaration relies on the original node.
+
+ Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node));
+
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
@@ -3755,7 +3760,7 @@ package body Exp_Ch5 is
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Array_Node),
+ Prefix => New_Copy_Tree (Array_Node),
Attribute_Name => Name_Range,
Expressions=> New_List (
Make_Integer_Literal (Loc, Dim1))),
@@ -3792,7 +3797,7 @@ package body Exp_Ch5 is
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
-Prefix => Relocate_Node (Array_Node),
+Prefix => New_Copy_Tree (Array_Node),
Attribute_Name => Name_Range,
Expressions=> New_List (
Make_Integer_Literal (Loc, Dim1))),
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter2.adb
@@ -0,0 +1,28 @@
+-- { dg-do compile }
+-- { dg-options "-gnatd.F -gnatws" }
+
+package body Iter2
+ with SPARK_Mode
+is
+ function To_String (Name : String) return String
+ is
+ procedure Append (Result : in out String;
+Data :String)
+with Inline_Always;
+ procedure Append (Result : in out String;
+Data :String)
+ is
+ begin
+ for C of Data
+ loop
+Result (1) := C;
+ end loop;
+ end Append;
+
+ Result : String (1 .. 3);
+ begin
+ Append (Result, "");
+ return Result;
+ end To_String;
+
+end Iter2;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter2.ads
@@ -0,0 +1,5 @@
+package Iter2
+ with SPARK_Mode
+is
+ function To_String (Name : String) return String;
+end Iter2;
[Ada] Segmentation_Fault with Integer'Wide_Wide_Value
This patch updates the routines which produce Wide_String and Wide_Wide_String
from a String to construct a result of the proper maximum size which is later
sliced.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* libgnat/s-wchwts.adb (Wide_String_To_String): Use the appropriate
longest sequence factor. Code clean up.
(Wide_Wide_String_To_String): Use the appropriate longest sequence
factor. Code clean up.
gcc/testsuite/
* gnat.dg/wide_wide_value1.adb: New testcase.--- gcc/ada/libgnat/s-wchwts.adb
+++ gcc/ada/libgnat/s-wchwts.adb
@@ -86,16 +86,23 @@ package body System.WCh_WtS is
(S : Wide_String;
EM : WC_Encoding_Method) return String
is
- R : String (S'First .. S'First + 5 * S'Length); -- worst case length
- RP : Natural;
+ Max_Chars : constant Natural := WC_Longest_Sequences (EM);
+
+ Result : String (S'First .. S'First + Max_Chars * S'Length);
+ Result_Idx : Natural;
begin
- RP := R'First - 1;
- for SP in S'Range loop
- Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM);
+ Result_Idx := Result'First - 1;
+
+ for S_Idx in S'Range loop
+ Store_UTF_32_Character
+ (U => Wide_Character'Pos (S (S_Idx)),
+S => Result,
+P => Result_Idx,
+EM => EM);
end loop;
- return R (R'First .. RP);
+ return Result (Result'First .. Result_Idx);
end Wide_String_To_String;
@@ -106,17 +113,23 @@ package body System.WCh_WtS is
(S : Wide_Wide_String;
EM : WC_Encoding_Method) return String
is
- R : String (S'First .. S'First + 7 * S'Length); -- worst case length
- RP : Natural;
+ Max_Chars : constant Natural := WC_Longest_Sequences (EM);
- begin
- RP := R'First - 1;
+ Result : String (S'First .. S'First + Max_Chars * S'Length);
+ Result_Idx : Natural;
- for SP in S'Range loop
- Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM);
+ begin
+ Result_Idx := Result'First - 1;
+
+ for S_Idx in S'Range loop
+ Store_UTF_32_Character
+ (U => Wide_Wide_Character'Pos (S (S_Idx)),
+S => Result,
+P => Result_Idx,
+EM => EM);
end loop;
- return R (R'First .. RP);
+ return Result (Result'First .. Result_Idx);
end Wide_Wide_String_To_String;
end System.WCh_WtS;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/wide_wide_value1.adb
@@ -0,0 +1,60 @@
+-- { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Wide_Wide_Value1 is
+begin
+ begin
+ declare
+ Str : constant Wide_Wide_String :=
+ Wide_Wide_Character'Val (16#0411#) &
+ Wide_Wide_Character'Val (16#043e#) &
+ Wide_Wide_Character'Val (16#0434#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0443#) &
+ Wide_Wide_Character'Val (16#0431#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0435#) &
+ Wide_Wide_Character'Val (16#0432#) &
+ Wide_Wide_Character'Val (16#0416#) &
+ Wide_Wide_Character'Val (16#0443#) &
+ Wide_Wide_Character'Val (16#043c#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0442#) &
+ Wide_Wide_Character'Val (16#041c#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0440#) &
+ Wide_Wide_Character'Val (16#0430#) &
+ Wide_Wide_Character'Val (16#0442#) &
+ Wide_Wide_Character'Val (16#043e#) &
+ Wide_Wide_Character'Val (16#0432#) &
+ Wide_Wide_Character'Val (16#0438#) &
+ Wide_Wide_Character'Val (16#0447#);
+
+ Val : constant Integer := Integer'Wide_Wide_Value (Str);
+ begin
+ Put_Line ("ERROR: 1: Constraint_Error not raised");
+ end;
+ exception
+ when Constraint_Error =>
+ null;
+ when others =>
+ Put_Line ("ERROR: 1: unexpected exception");
+ end;
+
+ begin
+ declare
+ Str : Wide_Wide_String (1 .. 128) :=
+ (others => Wide_Wide_Character'Val (16#0FFF#));
+
+ Val : constant Integer := Integer'Wide_Wide_Value (Str);
+ begin
+ Put_Line ("ERROR: 1: Constraint_Error not raised");
+ end;
+ exception
+ when Constraint_Error =>
+ null;
+ when others =>
+ Put_Line ("ERROR: 1: unexpected exception");
+ end;
+end Wide_Wide_Value1;
[Ada] Code cleanup on functions inlining
This patch is preventive: it improves checks on inline functions that
return unconstrained type. It does not change the functionality of
the compiler.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Javier Miranda
gcc/ada/
* inline.adb (Build_Body_To_Inline): Minor code reorganization that
ensures that calls to function Has_Single_Return() pass a decorated
tree.
(Has_Single_Return.Check_Return): Peform checks on entities (instead on
relying on their characters).--- gcc/ada/inline.adb
+++ gcc/ada/inline.adb
@@ -1085,33 +1085,9 @@ package body Inline is
Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
return;
- -- Functions that return unconstrained composite types require
- -- secondary stack handling, and cannot currently be inlined, unless
- -- all return statements return a local variable that is the first
- -- local declaration in the body.
-
- elsif Ekind (Spec_Id) = E_Function
-and then not Is_Scalar_Type (Etype (Spec_Id))
-and then not Is_Access_Type (Etype (Spec_Id))
-and then not Is_Constrained (Etype (Spec_Id))
- then
- if not Has_Single_Return (N)
-
- -- Skip inlining if the function returns an unconstrained type
- -- using an extended return statement, since this part of the
- -- new inlining model is not yet supported by the current
- -- implementation. ???
-
- or else (Returns_Unconstrained_Type (Spec_Id)
- and then Has_Extended_Return)
- then
-Cannot_Inline
- ("cannot inline & (unconstrained return type)?", N, Spec_Id);
-return;
- end if;
-
- -- Ditto for functions that return controlled types, where controlled
- -- actions interfere in complex ways with inlining.
+ -- Functions that return controlled types cannot currently be inlined
+ -- because they require secondary stack handling; controlled actions
+ -- may also interfere in complex ways with inlining.
elsif Ekind (Spec_Id) = E_Function
and then Needs_Finalization (Etype (Spec_Id))
@@ -1234,10 +1210,37 @@ package body Inline is
Restore_Env;
end if;
+ -- Functions that return unconstrained composite types require
+ -- secondary stack handling, and cannot currently be inlined, unless
+ -- all return statements return a local variable that is the first
+ -- local declaration in the body. We had to delay this check until
+ -- the body of the function is analyzed since Has_Single_Return()
+ -- requires a minimum decoration.
+
+ if Ekind (Spec_Id) = E_Function
+and then not Is_Scalar_Type (Etype (Spec_Id))
+and then not Is_Access_Type (Etype (Spec_Id))
+and then not Is_Constrained (Etype (Spec_Id))
+ then
+ if not Has_Single_Return (Body_To_Analyze)
+
+ -- Skip inlining if the function returns an unconstrained type
+ -- using an extended return statement, since this part of the
+ -- new inlining model is not yet supported by the current
+ -- implementation. ???
+
+ or else (Returns_Unconstrained_Type (Spec_Id)
+ and then Has_Extended_Return)
+ then
+Cannot_Inline
+ ("cannot inline & (unconstrained return type)?", N, Spec_Id);
+return;
+ end if;
+
-- If secondary stack is used, there is no point in inlining. We have
-- already issued the warning in this case, so nothing to do.
- if Uses_Secondary_Stack (Body_To_Analyze) then
+ elsif Uses_Secondary_Stack (Body_To_Analyze) then
return;
end if;
@@ -3904,17 +3907,23 @@ package body Inline is
if Present (Expression (N))
and then Is_Entity_Name (Expression (N))
then
+ pragma Assert (Present (Entity (Expression (N;
+
if No (Return_Statement) then
Return_Statement := N;
return OK;
- elsif Chars (Expression (N)) =
- Chars (Expression (Return_Statement))
- then
- return OK;
-
else
- return Abandon;
+ pragma Assert
+(Present (Entity (Expression (Return_Statement;
+
+ if Entity (Expression (N)) =
+ Entity (Expression (Return_Statement))
+ then
+ return OK;
+ else
+ return Abandon;
+ end if;
end if;
-- A return statement within an extended return is a noop
@@ -3963,8 +3972,8 @@ package body Inline is
else
return Present (Declarations (N))
and then Present (First (Declar
[Ada] Spurious possible contraint error warning with No_Exception_Propagation
This patch corrects an issue whereby spurious unhandled exception warnings on integer literals within static if and case expressions would be emitted when the restriction No_Exception_Propagation is enabled. -- Source -- -- gnat.adc pragma Restrictions (No_Exception_Propagation); pragma SPARK_Mode (On); -- pack.ads package Pack is procedure Filter (Ret : out Integer); end Pack; -- pack.adb package body Pack is subtype Nat is Integer range 0 .. 10; Default : constant Nat := 1; User_Override : constant Integer := -1; procedure Filter (Ret : out Integer) is Val : constant Nat := (if User_Override in Nat then User_Override else Default); begin Ret := Val; end Filter; end Pack; -- Compilation and output -- & gcc -c -gnatp -gnatwa pack.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Justin Squirek gcc/ada/ * sem_eval.adb (Eval_Integer_Literal): Add exception for avoiding checks on expanded literals within if and case expressions.--- gcc/ada/sem_eval.adb +++ gcc/ada/sem_eval.adb @@ -2720,16 +2720,23 @@ package body Sem_Eval is -- Start of processing for Eval_Integer_Literal begin - -- If the literal appears in a non-expression context, then it is -- certainly appearing in a non-static context, so check it. This is -- actually a redundant check, since Check_Non_Static_Context would -- check it, but it seems worthwhile to optimize out the call. - -- An exception is made for a literal in an if or case expression + -- Additionally, when the literal appears within an if or case + -- expression it must be checked as well. However, due to the literal + -- appearing within a conditional statement, expansion greatly changes + -- the nature of its context and performing some of the checks within + -- Check_Non_Static_Context on an expanded literal may lead to spurious + -- and misleading warnings. if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative) or else Nkind (Parent (N)) not in N_Subexpr) +and then (not Nkind_In (Parent (N), N_If_Expression, + N_Case_Expression_Alternative) + or else Comes_From_Source (N)) and then not In_Any_Integer_Context then Check_Non_Static_Context (N);
[Ada] Crash on Indefinite_Hashed_Maps with -gnata -gnateV
This patch corrects the generation of helper functions which verify the
validity of record type scalar discriminants and scalar components when
switches -gnata (assertions enabled) and -gnateV (validity checks on
subprogram parameters) are in effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with
class-wide types and record extensions.
gcc/testsuite/
* gnat.dg/validity_check3.adb, gnat.dg/validity_check3.ads: New
testcase.--- gcc/ada/exp_attr.adb
+++ gcc/ada/exp_attr.adb
@@ -724,13 +724,44 @@ package body Exp_Attr is
Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
- Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ);
- Rec_Def : constant Node_Id := Type_Definition (Rec_Decl);
+ Comps: Node_Id;
Stmts: List_Id;
+ Typ : Entity_Id;
+ Typ_Decl : Node_Id;
+ Typ_Def : Node_Id;
+ Typ_Ext : Node_Id;
-- Start of processing for Build_Record_VS_Func
begin
+ Typ := Rec_Typ;
+
+ -- Use the root type when dealing with a class-wide type
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ_Decl := Declaration_Node (Typ);
+ Typ_Def := Type_Definition (Typ_Decl);
+
+ -- The components of a derived type are located in the extension part
+
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Ext := Record_Extension_Part (Typ_Def);
+
+ if Present (Typ_Ext) then
+Comps := Component_List (Typ_Ext);
+ else
+Comps := Empty;
+ end if;
+
+ -- Otherwise the components are available in the definition
+
+ else
+ Comps := Component_List (Typ_Def);
+ end if;
+
-- The code generated by this routine is as follows:
--
--function Func_Id (Obj_Id : Formal_Typ) return Boolean is
@@ -774,7 +805,7 @@ package body Exp_Attr is
if not Is_Unchecked_Union (Rec_Typ) then
Validate_Fields
(Obj_Id => Obj_Id,
-Fields => Discriminant_Specifications (Rec_Decl),
+Fields => Discriminant_Specifications (Typ_Decl),
Stmts => Stmts);
end if;
@@ -782,7 +813,7 @@ package body Exp_Attr is
Validate_Component_List
(Obj_Id=> Obj_Id,
- Comp_List => Component_List (Rec_Def),
+ Comp_List => Comps,
Stmts => Stmts);
-- Generate:
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/validity_check3.adb
@@ -0,0 +1,96 @@
+-- { dg-do compile }
+-- { dg-options "-gnata -gnateV" }
+
+package body Validity_Check3 is
+ procedure Proc_Priv_CW_1 (Param : Tag_1'Class) is begin null; end;
+ procedure Proc_Priv_CW_2 (Param : Tag_2'Class) is begin null; end;
+ procedure Proc_Priv_CW_3 (Param : Tag_3'Class) is begin null; end;
+ procedure Proc_Priv_CW_4 (Param : Tag_4'Class) is begin null; end;
+ procedure Proc_Priv_CW_5 (Param : Tag_5'Class) is begin null; end;
+ procedure Proc_Priv_CW_6 (Param : Tag_6'Class) is begin null; end;
+
+ procedure Proc_Priv_Rec_1 (Param : Rec_1) is begin null; end;
+ procedure Proc_Priv_Rec_2 (Param : Rec_2) is begin null; end;
+ procedure Proc_Priv_Rec_3 (Param : Rec_3) is begin null; end;
+ procedure Proc_Priv_Rec_4 (Param : Rec_4) is begin null; end;
+
+ procedure Proc_Priv_Tag_1 (Param : Tag_1) is begin null; end;
+ procedure Proc_Priv_Tag_2 (Param : Tag_2) is begin null; end;
+ procedure Proc_Priv_Tag_3 (Param : Tag_3) is begin null; end;
+ procedure Proc_Priv_Tag_4 (Param : Tag_4) is begin null; end;
+ procedure Proc_Priv_Tag_5 (Param : Tag_5) is begin null; end;
+ procedure Proc_Priv_Tag_6 (Param : Tag_6) is begin null; end;
+
+ procedure Proc_Vis_CW_1 (Param : Tag_1'Class) is begin null; end;
+ procedure Proc_Vis_CW_2 (Param : Tag_2'Class) is begin null; end;
+ procedure Proc_Vis_CW_3 (Param : Tag_3'Class) is begin null; end;
+ procedure Proc_Vis_CW_4 (Param : Tag_4'Class) is begin null; end;
+ procedure Proc_Vis_CW_5 (Param : Tag_5'Class) is begin null; end;
+ procedure Proc_Vis_CW_6 (Param : Tag_6'Class) is begin null; end;
+
+ procedure Proc_Vis_Rec_1 (Param : Rec_1) is begin null; end;
+ procedure Proc_Vis_Rec_2 (Param : Rec_2) is begin null; end;
+ procedure Proc_Vis_Rec_3 (Param : Rec_3) is begin null; end;
+ procedure Proc_Vis_Rec_4 (Param : Rec_4) is begin null; end;
+
+ procedure Proc_Vis_Tag_1 (Param : Tag_1) is begin null; end;
+ procedure Proc_Vis_Tag_2 (Param : Tag_2) is begin null; end;
+ procedure Proc_Vis_Tag_3 (Param : Tag_3) is begin null; end;
+ procedure Proc_Vis_Tag_4 (Param : Tag_4) is begin null; end;
+ procedure Proc_Vis_Tag_5 (Param : Tag_5) is begin null; end;
+ procedure Proc_Vis_Tag_6 (Param : Tag_6) is begin n
[Ada] Deconstruct always-false calls to Withed_Body in Walk_Library_Items
We previously removed the calls to Set_Withed_Body; this commit deconstructs calls to Withed_Body, which always returned False. The Set_Withed_Body/Withed_Body were helping the Walk_Library_Items routine traverse the AST of several compilation units such that declarations are visited before references. However, this never worked as it should and there is no point to keep the code more complicated than necessary. No test provided, because thie removed code was ineffective (and only used in the non-compiler backends, i.e. CodePeer and GNATprove). Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sem.adb (Walk_Library_Items): Deconstruct dead code.--- gcc/ada/sem.adb +++ gcc/ada/sem.adb @@ -36,7 +36,6 @@ with Nlists;use Nlists; with Output;use Output; with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; -with Sem_Aux; use Sem_Aux; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -1705,7 +1704,7 @@ package body Sem is -- The main unit and its spec may depend on bodies that contain generics -- that are instantiated in them. Iterate through the corresponding -- contexts before processing main (spec/body) itself, to process bodies - -- that may be present, together with their context. The spec of main + -- that may be present, together with their context. The spec of main -- is processed wherever it appears in the list of units, while the body -- is processed as the last unit in the list. @@ -2020,8 +2019,7 @@ package body Sem is if Present (Body_CU) and then Body_CU /= Cunit (Main_Unit) and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body - and then (Nkind (Unit (Comp)) /= N_Package_Declaration - or else Present (Withed_Body (Clause))) + and then Nkind (Unit (Comp)) /= N_Package_Declaration then Body_U := Get_Cunit_Unit_Number (Body_CU); @@ -2335,7 +2333,6 @@ package body Sem is Context_Item : Node_Id; Lib_Unit : Node_Id; - Body_CU : Node_Id; begin Context_Item := First (Context_Items (CU)); @@ -2346,30 +2343,6 @@ package body Sem is then Lib_Unit := Library_Unit (Context_Item); Action (Lib_Unit); - --- If the context item indicates that a package body is needed --- because of an instantiation in CU, traverse the body now, even --- if CU is not related to the main unit. If the generic itself --- appears in a package body, the context item is this body, and --- it already appears in the traversal order, so we only need to --- examine the case of a context item being a package declaration. - -if Present (Withed_Body (Context_Item)) - and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration - and then Present (Corresponding_Body (Unit (Lib_Unit))) -then - Body_CU := - Parent - (Unit_Declaration_Node - (Corresponding_Body (Unit (Lib_Unit; - - -- A body may have an implicit with on its own spec, in which - -- case we must ignore this context item to prevent looping. - - if Unit (CU) /= Unit (Body_CU) then - Action (Body_CU); - end if; -end if; end if; Context_Item := Next (Context_Item);
[Ada] Spurious error with null Abstract_State
This patch corrects the mechanism which ensures that a package with a null
Abstract_State does not introduce hidden state, by ignoring internal states
and variables because they do not represent the "source" hidden state.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-16 Hristian Kirtchev
gcc/ada/
* sem_util.adb (Check_No_Hidden_State): Ignore internally-generated
states and variables.
gcc/testsuite/
* gnat.dg/abstract_state1.adb, gnat.dg/abstract_state1.ads: New
testcase.--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -3228,6 +3228,13 @@ package body Sem_Util is
begin
pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
+ -- Nothing to do for internally-generated abstract states and variables
+ -- because they do not represent the hidden state of the source unit.
+
+ if not Comes_From_Source (Id) then
+ return;
+ end if;
+
-- Find the proper context where the object or state appears
Scop := Scope (Id);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/abstract_state1.adb
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+
+package body Abstract_State1 is
+ procedure Foo is null;
+end Abstract_State1;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/abstract_state1.ads
@@ -0,0 +1,24 @@
+package Abstract_State1
+ with Abstract_State => null,
+ Initializes=> null
+is
+ type Complex (B : Boolean) is tagged private;
+ type No_F is tagged private;
+ X : constant No_F;
+
+ procedure Foo;
+
+private
+ type Complex (B : Boolean) is tagged record
+ G : Integer;
+ case B is
+ when True =>
+F : Integer;
+ when False =>
+null;
+ end case;
+ end record;
+
+ type No_F is new Complex (False) with null record;
+ X : constant No_F := (B => False, G => 7);
+end Abstract_State1;
[Ada] Avoid crash when traversing units with -gnatd.WW debug switch
The debug switch -gnatd.WW enables extra info when traversing library units with Walk_Library_Items, which is used in the CodePeer and GNATprove. This routine was crashing when trying to print info about a unit with configuration pragmas (typically an .adc file). Now fixed. No test, as the crash only happens when a GNATprove backend is manually called with -gnatd.WW switch. Frontend is not affected. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sem.adb (Walk_Library_Items): Skip units with configuration pragmas when printing debug info.--- gcc/ada/sem.adb +++ gcc/ada/sem.adb @@ -2242,8 +2242,14 @@ package body Sem is for Unit_Num in Done'Range loop if not Done (Unit_Num) then - Write_Unit_Info -(Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + + -- Units with configuration pragmas (.ads files) have empty + -- compilation-unit nodes; skip printing info about them. + + if Present (Cunit (Unit_Num)) then + Write_Unit_Info + (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + end if; end if; end loop;
[Ada] Deconstruct unused Withed_Body filed of N_With_Clause node
The Withed_Body field was added to N_With_Clause node to help the Walk_Library_Items routine, which was created for the CodePeer backend and later adopted by the GNATprove. This routine is meant to traverse all library units, such that declarations are visited before references. However, for complex units (in particular, with generics and child packages) it never worked reliably and backends developed their own workarounds. This patch deconstructs the field, as it hasn't been used for years. Semantics unaffected; no test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Piotr Trojanek gcc/ada/ * sinfo.ads, sinfo.adb (Withed_Body): Remove. (Set_Withed_Body): Remove.--- gcc/ada/sinfo.adb +++ gcc/ada/sinfo.adb @@ -3522,14 +3522,6 @@ package body Sinfo is return Flag13 (N); end Was_Originally_Stub; - function Withed_Body - (N : Node_Id) return Node_Id is - begin - pragma Assert (False -or else NT (N).Nkind = N_With_Clause); - return Node1 (N); - end Withed_Body; - -- -- Field Set Procedures -- -- @@ -6990,14 +6982,6 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Was_Originally_Stub; - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False -or else NT (N).Nkind = N_With_Clause); - Set_Node1 (N, Val); - end Set_Withed_Body; - - -- Iterator Procedures -- - --- gcc/ada/sinfo.ads +++ gcc/ada/sinfo.ads @@ -2504,12 +2504,6 @@ package Sinfo is --Original_Node here because of the case of nested instantiations where --the substituted node can be copied. - -- Withed_Body (Node1-Sem) - --Present in N_With_Clause nodes. Set if the unit in whose context - --the with_clause appears instantiates a generic contained in the - --library unit of the with_clause and as a result loads its body. - --Used for a more precise unit traversal for CodePeer. - -- -- Note on Use of End_Label and End_Span Fields -- -- @@ -6743,7 +6737,6 @@ package Sinfo is -- N_With_Clause -- Sloc points to first token of library unit name - -- Withed_Body (Node1-Sem) -- Name (Node2) -- Private_Present (Flag15) set if with_clause has private keyword -- Limited_Present (Flag17) set if LIMITED is present @@ -10307,9 +10300,6 @@ package Sinfo is function Was_Originally_Stub (N : Node_Id) return Boolean;-- Flag13 - function Withed_Body - (N : Node_Id) return Node_Id;-- Node1 - -- End functions (note used by xsinfo utility program to end processing) @@ -11408,9 +11398,6 @@ package Sinfo is procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True);-- Flag13 - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id);-- Node1 - - -- Iterator Procedures -- - @@ -13613,7 +13600,6 @@ package Sinfo is pragma Inline (Was_Attribute_Reference); pragma Inline (Was_Expression_Function); pragma Inline (Was_Originally_Stub); - pragma Inline (Withed_Body); pragma Inline (Set_Abort_Present); pragma Inline (Set_Abortable_Part); @@ -13975,6 +13961,5 @@ package Sinfo is pragma Inline (Set_Was_Attribute_Reference); pragma Inline (Set_Was_Expression_Function); pragma Inline (Set_Was_Originally_Stub); - pragma Inline (Set_Withed_Body); end Sinfo;
[Ada] Missing error on hidden state in instantiation
This patch modifies the analysis of package contracts to split processing which is specific to package instantiations on its own. As a result, the lack of indicator Part_Of can now be properly assessed. -- Source -- -- gen_pack.ads generic package Gen_Pack is Pack_Var : Integer := 1; end Gen_Pack; -- gen_wrap.ads with Gen_Pack; generic package Gen_Wrap is Wrap_Var : Integer := 1; package Inst is new Gen_Pack; end Gen_Wrap; -- pack.ads with Gen_Pack; with Gen_Wrap; package Pack with SPARK_Mode => On, Abstract_State => State is procedure Force_Body; private package OK_Inst_1 is new Gen_Pack -- OK with Part_Of => State; -- OK package OK_Inst_2 is new Gen_Pack;-- OK pragma Part_Of (State); -- OK package OK_Inst_3 is new Gen_Wrap -- OK with Part_Of => State; -- OK package OK_Inst_4 is new Gen_Wrap;-- OK pragma Part_Of (State); package Error_Inst_1 is new Gen_Pack; -- Error package Error_Inst_2 is new Gen_Wrap; -- Error end Pack; -- pack.adb package body Pack with SPARK_Mode=> On, Refined_State => (State => (OK_Inst_1.Pack_Var, OK_Inst_2.Pack_Var, OK_Inst_3.Wrap_Var, OK_Inst_3.Inst.Pack_Var, OK_Inst_4.Wrap_Var, OK_Inst_4.Inst.Pack_Var)) is procedure Force_Body is null; end Pack; -- Compilation and output -- $ gcc -c pack.adb pack.ads:23:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:23:12: "Error_Inst_1" is declared in the private part of package "Pack" pack.ads:24:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:24:12: "Error_Inst_2" is declared in the private part of package "Pack" Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-16 Hristian Kirtchev gcc/ada/ * contracts.adb (Analyze_Contracts): Add specialized processing for package instantiation contracts. (Analyze_Package_Contract): Remove the verification of a missing Part_Of indicator. (Analyze_Package_Instantiation_Contract): New routine. * contracts.ads (Analyze_Package_Contract): Update the comment on usage. * sem_prag.adb (Check_Missing_Part_Of): Ensure that the entity of the instance is being examined when trying to determine whether a package instantiation needs a Part_Of indicator.--- gcc/ada/contracts.adb +++ gcc/ada/contracts.adb @@ -53,6 +53,13 @@ with Tbuild; use Tbuild; package body Contracts is + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of package + -- instantiation Inst_Id as if they appear at the end of a declarative + -- region. The pragmas in question are: + -- + --Part_Of + procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the -- contract-only subprogram body of eligible subprograms found in L, adds @@ -386,6 +393,11 @@ package body Contracts is elsif Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); + -- Package instantiation + + elsif Nkind (Decl) = N_Package_Instantiation then +Analyze_Package_Instantiation_Contract (Defining_Entity (Decl)); + -- Protected units elsif Nkind_In (Decl, N_Protected_Type_Declaration, @@ -1074,17 +1086,6 @@ package body Contracts is end if; end if; - -- Check whether the lack of indicator Part_Of agrees with the placement - -- of the package instantiation with respect to the state space. - - if Is_Generic_Instance (Pack_Id) then - Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); - - if No (Prag) then -Check_Missing_Part_Of (Pack_Id); - end if; - end if; - -- Restore the SPARK_Mode of the enclosing context after all delayed -- pragmas have been analyzed. @@ -1100,6 +1101,62 @@ package body Contracts is end if; end Analyze_Package_Contract; + + -- Analyze_Package_Instantiation_Contract -- + + + -- WARNING: This routine manages SPARK regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- SPARK mode. + + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id) is + Inst_Spec : constant Node_Id :
[Ada] Fix Next_Actual when used on calls "inlined for proof"
The GNATprove backend needs to apply antialiasing checks to subprogram calls that have been rewritten into null statements while "inlining for proof". This requires the First_Actual/Next_Actual to use the Original_Node and not the N_Null_Statement that rewriting leaves as a parent. Only effective in GNATprove mode, so no frontend test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Piotr Trojanek gcc/ada/ * sem_util.adb (Next_Actual): If the parent is a N_Null_Statement, which happens for inlined calls, then fetch the next actual from the original AST.--- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -21033,7 +21033,8 @@ package body Sem_Util is - function Next_Actual (Actual_Id : Node_Id) return Node_Id is - N : Node_Id; + N : Node_Id; + Par : constant Node_Id := Parent (Actual_Id); begin -- If we are pointing at a positional parameter, it is a member of a @@ -21053,11 +21054,22 @@ package body Sem_Util is -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. -if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) +if Nkind_In (Par, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then - return First_Named_Actual (Parent (Actual_Id)); + return First_Named_Actual (Par); + +-- In case of a call rewritten in GNATprove mode while "inlining +-- for proof" go to the original call. + +elsif Nkind (Par) = N_Null_Statement then + pragma Assert + (GNATprove_Mode +and then + Nkind (Original_Node (Par)) in N_Subprogram_Call); + + return First_Named_Actual (Original_Node (Par)); else return Empty; end if;
[Ada] Add elaboration-related switches to GNAT UGN
This patch adds compiler switches -gnatH and -gnatJ to section "Alphabetical
list of all switches" of the GNAT User Guide for Native.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Hristian Kirtchev
gcc/ada/
* doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add missing
sections on -gnatH and -gnatJ compiler switches.
* gnat_ugn.texi: Regenerate.--- gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -720,9 +720,9 @@ is passed to ``gcc`` (e.g., :switch:`-O`, :switch:`-gnato,` etc.)
.. index:: --RTS (gnatmake)
:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. GNAT looks for the
- runtime
- in the following directories, and stops as soon as a valid runtime is found
+ Specifies the default location of the run-time library. GNAT looks for the
+ run-time
+ in the following directories, and stops as soon as a valid run-time is found
(:file:`adainclude` or :file:`ada_source_path`, and :file:`adalib` or
:file:`ada_object_path` present):
@@ -1505,7 +1505,7 @@ Alphabetical List of All Switches
In the example above, the first call to ``Detect_Aliasing`` fails with a
- ``Program_Error`` at runtime because the actuals for ``Val_1`` and
+ ``Program_Error`` at run time because the actuals for ``Val_1`` and
``Val_2`` denote the same object. The second call executes without raising
an exception because ``Self(Obj)`` produces an anonymous object which does
not share the memory location of ``Obj``.
@@ -1817,14 +1817,12 @@ Alphabetical List of All Switches
.. index:: -gnatg (gcc)
:switch:`-gnatg`
- Internal GNAT implementation mode. This should not be used for
- applications programs, it is intended only for use by the compiler
- and its run-time library. For documentation, see the GNAT sources.
- Note that :switch:`-gnatg` implies
- :switch:`-gnatw.ge` and
- :switch:`-gnatyg`
- so that all standard warnings and all standard style options are turned on.
- All warnings and style messages are treated as errors.
+ Internal GNAT implementation mode. This should not be used for applications
+ programs, it is intended only for use by the compiler and its run-time
+ library. For documentation, see the GNAT sources. Note that :switch:`-gnatg`
+ implies :switch:`-gnatw.ge` and :switch:`-gnatyg` so that all standard
+ warnings and all standard style options are turned on. All warnings and style
+ messages are treated as errors.
.. index:: -gnatG[nn] (gcc)
@@ -1839,6 +1837,13 @@ Alphabetical List of All Switches
Output usage information. The output is written to :file:`stdout`.
+.. index:: -gnatH (gcc)
+
+:switch:`-gnatH`
+ Legacy elaboration-checking mode enabled. When this switch is in effect, the
+ pre-18.x access-before-elaboration model becomes the de facto model.
+
+
.. index:: -gnati (gcc)
:switch:`-gnati{c}`
@@ -1874,6 +1879,27 @@ Alphabetical List of All Switches
Reformat error messages to fit on ``nn`` character lines
+.. index:: -gnatJ (gcc)
+
+:switch:`-gnatJ`
+ Permissive elaboration-checking mode enabled. When this switch is in effect,
+ the post-18.x access-before-elaboration model ignores potential issues with:
+
+ - Accept statements
+ - Activations of tasks defined in instances
+ - Assertion pragmas
+ - Calls from within an instance to its enclosing context
+ - Calls through generic formal parameters
+ - Calls to subprograms defined in instances
+ - Entry calls
+ - Indirect calls using 'Access
+ - Requeue statements
+ - Select statements
+ - Synchronous task suspension
+
+ and does not emit compile-time diagnostics or run-time checks.
+
+
.. index:: -gnatk (gcc)
:switch:`-gnatk={n}`
@@ -2195,7 +2221,7 @@ Alphabetical List of All Switches
.. index:: --RTS (gcc)
:switch:`--RTS={rts-path}`
- Specifies the default location of the runtime library. Same meaning as the
+ Specifies the default location of the run-time library. Same meaning as the
equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`).
@@ -5062,7 +5088,7 @@ switches refine this default behavior.
that a certain check will necessarily fail, it will generate code to
do an unconditional 'raise', even if checks are suppressed. The
compiler warns in this case. Another case in which checks may not be
- eliminated is when they are embedded in certain run time routines such
+ eliminated is when they are embedded in certain run-time routines such
as math library routines.
Of course, run-time checks are omitted whenever the compiler can prove
@@ -5858,7 +5884,7 @@ Debugging Control
Exception Handling Control
--
-GNAT uses two methods for handling exceptions at run-time. The
+GNAT uses two methods for handling exceptions at run time. The
``setjmp/longjmp`` method saves the context when entering
a frame with an exception handler. Then whe
[Ada] Secondary stack leak in loop iterator
When the evaluation of the loop iterator invokes a function whose result relies on the secondary stack the compiler does not generate code to release the consumed memory as soon as the loop terminates. After this patch the following test works fine. with Text_IO; use Text_IO; pragma Warnings (Off); with System.Secondary_Stack; pragma Warnings (On); procedure Sec_Stack_Leak is function F (X : String) return Integer is begin return 10; end F; function G (X : Integer) return String is begin return (1 .. X => 'x'); end G; procedure Info is new System.Secondary_Stack.Ss_Info (Put_Line); procedure Nest is begin for I in Integer range 1 .. 100 loop for J in Integer range 1 .. F (G (10_000)) loop null; end loop; Info; end loop; Info; end Nest; begin Info; Nest; Info; end Sec_Stack_Leak; Commands: gnatmake -q sec_stack_leak.adb sec_stack_leak | grep "Current allocated space :" | uniq Output: Current allocated space : 0 bytes Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level to reuse it. (Analyze_Loop_Statement): Wrap the loop in a block when the evaluation of the loop iterator relies on the secondary stack.--- gcc/ada/sem_ch5.adb +++ gcc/ada/sem_ch5.adb @@ -83,6 +83,12 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; + -- N is the node for an arbitrary construct. This function searches the + -- construct N to see if any expressions within it contain function + -- calls that use the secondary stack, returning True if any such call + -- is found, and False otherwise. + procedure Preanalyze_Range (R_Copy : Node_Id); -- Determine expected type of range or domain of iteration of Ada 2012 -- loop by analyzing separate copy. Do the analysis and resolution of the @@ -2692,12 +2698,6 @@ package body Sem_Ch5 is -- forms. In this case it is not sufficent to check the static predicate -- function only, look for a dynamic predicate aspect as well. - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; - -- N is the node for an arbitrary construct. This function searches the - -- construct N to see if any expressions within it contain function - -- calls that use the secondary stack, returning True if any such call - -- is found, and False otherwise. - procedure Process_Bounds (R : Node_Id); -- If the iteration is given by a range, create temporaries and -- assignment statements block to capture the bounds and perform @@ -2782,65 +2782,6 @@ package body Sem_Ch5 is end if; end Check_Predicate_Use; - - -- Has_Call_Using_Secondary_Stack -- - - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is - function Check_Call (N : Node_Id) return Traverse_Result; - -- Check if N is a function call which uses the secondary stack - - - -- Check_Call -- - - - function Check_Call (N : Node_Id) return Traverse_Result is -Nam : Node_Id; -Subp : Entity_Id; -Typ : Entity_Id; - - begin -if Nkind (N) = N_Function_Call then - Nam := Name (N); - - -- Obtain the subprogram being invoked - - loop - if Nkind (Nam) = N_Explicit_Dereference then - Nam := Prefix (Nam); - - elsif Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - - else - exit; - end if; - end loop; - - Subp := Entity (Nam); - Typ := Etype (Subp); - - if Requires_Transient_Scope (Typ) then - return Abandon; - - elsif Sec_Stack_Needed_For_Return (Subp) then - return Abandon; - end if; -end if; - --- Continue traversing the tree - -return OK; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Has_Call_Using_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Has_Call_Using_Secondary_Stack; - -- Process_Bounds -- @@ -3644,6 +3585,56 @@ package body Sem_Ch5 is end; end if; + -- Wrap the loop in a block when the evaluation of the loop iterator
[Ada] Attach the special GNATprove HEAP entity to the Standard package
In GNATprove mode we use frontend cross-references to synthesize the Global contract of subprograms with SPARK_Mode => Off and represent a read/write via a pointer as a read/write of a special entity called HEAP. This entity is now attached to the Standard package, so that we can safely check the Ekind of its Scope, which now happens in Scope_Within. This only affects GNATprove, so no frontend test provided. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Piotr Trojanek gcc/ada/ * lib-xref-spark_specific.adb (Create_Heap): Attach the HEAP entity to the Standard package.--- gcc/ada/lib-xref-spark_specific.adb +++ gcc/ada/lib-xref-spark_specific.adb @@ -287,6 +287,7 @@ package body SPARK_Specific is Set_Ekind (Heap, E_Variable); Set_Is_Internal (Heap, True); + Set_Scope (Heap, Standard_Standard); Set_Has_Fully_Qualified_Name (Heap); end Create_Heap;
[Ada] Crash on case expression in build-in-place function
This patch modifies the recursive tree replication routine New_Copy_Tree to create new entities and remap old entities to the new ones for constructs in N_Expression_With_Actions nodes when requested by a caller. This in turn allows the build-in-place mechanism to avoid sharing entities between the 4 variants of returns it generates. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping constructs and entities within receive new entities when replicating a tree. (Expand_N_Extended_Return_Statement): Ensure that scoping constructs and entities within receive new entities when replicating a tree. * sem_util.adb (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. (Visit_Entity): Visit entities within scoping constructs inside expression with actions nodes when requested by the caller. Add blocks, labels, and procedures to the list of entities which need replication. * sem_util.ads (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. Update the comment on usage. gcc/testsuite/ * gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.--- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -4562,7 +4562,10 @@ package body Exp_Ch6 is Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); - Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr); + Orig_Expr : constant Node_Id := + New_Copy_Tree +(Source => Alloc_Expr, + Scopes_In_EWA_OK => True); Stmts : constant List_Id := New_List; Desig_Typ : Entity_Id; Local_Id : Entity_Id; @@ -5022,7 +5025,10 @@ package body Exp_Ch6 is Init_Assignment := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Ret_Obj_Id, Loc), - Expression => New_Copy_Tree (Ret_Obj_Expr)); + Expression => +New_Copy_Tree + (Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True)); Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); @@ -5153,7 +5159,10 @@ package body Exp_Ch6 is Subtype_Mark => New_Occurrence_Of (Etype (Ret_Obj_Expr), Loc), -Expression => New_Copy_Tree (Ret_Obj_Expr))); +Expression => + New_Copy_Tree +(Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True))); else -- If the function returns a class-wide type we cannot @@ -5193,7 +5202,11 @@ package body Exp_Ch6 is -- except we set Storage_Pool and Procedure_To_Call so -- it will use the user-defined storage pool. - Pool_Allocator := New_Copy_Tree (Heap_Allocator); + Pool_Allocator := + New_Copy_Tree + (Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); -- Do not generate the renaming of the build-in-place @@ -5235,7 +5248,11 @@ package body Exp_Ch6 is -- allocation. else -SS_Allocator := New_Copy_Tree (Heap_Allocator); +SS_Allocator := + New_Copy_Tree +(Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); -- The heap and pool allocators are marked as --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -19505,10 +19505,11 @@ package body Sem_Util is --- function New_Copy_Tree - (Source: Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope: Entity_Id := Empty; + Scopes_In_EWA_OK : Boolean:= False) return Node_Id is -- This routine per
[Ada] New ignored Ghost code removal mechanism
This patch reimplements the mechanism which removes ignored Ghost code from the
tree.
The previous mechanism proved to be unreliable because it assumed that no new
scoping constructs would be created after some ignored Ghost code had already
notified its enclosing scoping constructs that they contain such code. The
assumption can be broken by having a call to an ignored Ghost procedure within
the extended return statement of a function. The procedure call would signal
the enclosing function that it contains ignored Ghost code, however the return
statement would introduce an extra block, effectively hiding the procedure call
from the ignored Ghost code elimination pass.
The new mechanism implemented in this patch forgoes directed tree pruning in
favor of storing the actual ignored Ghost code, and later directly eliminating
it from the tree.
For this approach to operate efficiently, only "top level" ignored Ghost
constructs are stored. The top level constructs are essentially nodes which can
appear within a declarative or statement list and be safely rewritten into null
statements. This ensures that only "root" ignored Ghost construct need to be
processed, as opposed to all ignored Ghost nodes within a subtree.
The approach has one drawback however. Due to the generation and analysis of
ignored Ghost code, a construct may be recorded multiple times (usually twice).
The mechanism simply deals with this artefact instead of employing expensive
solutions such as hash tables or a common flag shared by all nodes to eliminate
the duplicates.
-- Source --
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
procedure Ghost_Proc with Ghost;
procedure Ghost_Proc is
begin
Put_Line ("ERROR: Ghost_Proc called");
end Ghost_Proc;
function Func return Integer is
begin
return Res : Integer := 123 do
Ghost_Proc;
end return;
end Func;
Val : Integer with Ghost;
begin
Val := Func;
end Main;
-- Compilation and output --
$ gcc -c -gnatDG main.adb
$ grep -c "ghost" main.adb.dg
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Hristian Kirtchev
gcc/ada/
* alloc.ads: Update the allocation metrics of the ignored Ghost nodes
table.
* atree.adb: Add a soft link for a procedure which is invoked whenever
an ignored Ghost node or entity is created.
(Change_Node): Preserve relevant attributes which come from the Flags
table.
(Mark_New_Ghost_Node): Record a newly created ignored Ghost node or
entity.
(Rewrite): Preserve relevant attributes which come from the Flags
table.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* atree.ads: Define an access-to-suprogram type for a soft link which
records a newly created ignored Ghost node or entity.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* ghost.adb: Remove with and use clause for Lib. Remove table
Ignored_Ghost_Units. Add new table Ignored_Ghost_Nodes.
(Add_Ignored_Ghost_Unit): Removed.
(Initialize): Initialize the table which stores ignored Ghost nodes.
Set the soft link which allows Atree.Mark_New_Ghost_Node to record an
ignored Ghost node.
(Is_Ignored_Ghost_Unit): Use the ultimate original node when checking
an eliminated ignored Ghost unit.
(Lock): Release and lock the table which stores ignored Ghost nodes.
(Mark_And_Set_Ghost_Assignment): Record rather than propagate ignored
Ghost nodes.
(Mark_And_Set_Ghost_Procedure_Call): Record rather than propagate
ignored Ghost nodes.
(Mark_Ghost_Clause): Record rather than propagate ignored Ghost nodes.
(Mark_Ghost_Declaration_Or_Body): Record rather than propagate ignored
Ghost nodes.
(Mark_Ghost_Pragma): Record rather than propagate ignored Ghost nodes.
(Propagate_Ignored_Ghost_Code): Removed.
(Record_Ignored_Ghost_Node): New routine.
(Remove_Ignored_Ghost_Code): Reimplemented.
(Remove_Ignored_Ghost_Node): New routine.
(Ultimate_Original_Node): New routine.
* ghost.ads (Check_Ghost_Completion): Removed.
* sem_ch8.adb (Analyze_Use_Package): Remove obsolete code. Mark a use
package clause as ignored Ghost if applicable.
* sem_util.adb (Is_Body_Or_Package_Declaration): Reimplemented.--- gcc/ada/alloc.ads
+++ gcc/ada/alloc.ads
@@ -67,8 +67,8 @@ package Alloc is
In_Out_Warnings_Initial : constant := 100;-- Sem_Warn
In_Out_Warnings_Increment: constant := 100;
- Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util
- Ignored_Ghost_Units_Increment: constant := 50;
+ Ignored_Ghost_Nodes_Initial : constant := 100;-- Ghost
+ Ignored_Ghost_Nodes_Increment: constant := 100;
[Ada] Spurious error on unused Part_Of constituent
This patch updates the analysis of indicator Part_Of (or the lack thereof), to ignore generic formal parameters for purposes of determining the visible state space because they are not visible outside the generic and related instances. -- Source -- -- gen_pack.ads generic In_Formal : in Integer := 0; In_Out_Formal : in out Integer; package Gen_Pack is Exported_In_Formal : Integer renames In_Formal; Exported_In_Out_Formal : Integer renames In_Out_Formal; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => State is procedure Force_Body; Val : Integer; private package OK_1 is new Gen_Pack (In_Out_Formal => Val) with Part_Of => State;-- OK package OK_2 is new Gen_Pack (In_Formal => 1, In_Out_Formal => Val) with Part_Of => State;-- OK package Error_1 is-- Error new Gen_Pack (In_Out_Formal => Val); package Error_2 is-- Error new Gen_Pack (In_Formal => 2, In_Out_Formal => Val); end Pack; -- pack.adb package body Pack with Refined_State => -- Error (State => (OK_1.Exported_In_Formal, OK_1.Exported_In_Out_Formal)) is procedure Force_Body is null; end Pack; -- gen_pack.ads generic In_Formal : in Integer := 0; In_Out_Formal : in out Integer; package Gen_Pack is Exported_In_Formal : Integer renames In_Formal; Exported_In_Out_Formal : Integer renames In_Out_Formal; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => State is procedure Force_Body; Val : Integer; private package OK_1 is new Gen_Pack (In_Out_Formal => Val) with Part_Of => State;-- OK package OK_2 is new Gen_Pack (In_Formal => 1, In_Out_Formal => Val) with Part_Of => State;-- OK package Error_1 is-- Error new Gen_Pack (In_Out_Formal => Val); package Error_2 is-- Error new Gen_Pack (In_Formal => 2, In_Out_Formal => Val); end Pack; -- pack.adb package body Pack with Refined_State => -- Error (State => (OK_1.Exported_In_Formal, OK_1.Exported_In_Out_Formal)) is procedure Force_Body is null; end Pack; -- Compilation and output -- $ gcc -c pack.adb pack.adb:3:11: state "State" has unused Part_Of constituents pack.adb:3:11: constant "Exported_In_Formal" defined at gen_pack.ads:6, instance at pack.ads:15 pack.adb:3:11: variable "Exported_In_Out_Formal" defined at gen_pack.ads:7, instance at pack.ads:15 pack.ads:19:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:19:12: "Error_1" is declared in the private part of package "Pack" pack.ads:21:12: indicator Part_Of is required in this context (SPARK RM 7.2.6(2)) pack.ads:21:12: "Error_2" is declared in the private part of package "Pack" Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * sem_prag.adb (Has_Visible_State): Do not consider generic formals because they are not part of the visible state space. Add constants to the list of acceptable visible states. (Propagate_Part_Of): Do not consider generic formals when propagating the Part_Of indicator. * sem_util.adb (Entity_Of): Do not follow renaming chains which go through a generic formal because they are not visible for SPARK purposes. * sem_util.ads (Entity_Of): Update the comment on usage.--- gcc/ada/sem_prag.adb +++ gcc/ada/sem_prag.adb @@ -19982,6 +19982,13 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; + -- Do not consider generic formals or their corresponding + -- actuals because they are not part of a visible state. + -- Note that both entities are marked as hidden. + + elsif Is_Hidden (Item_Id) then +null; + -- The Part_Of indicator turns an abstract state or an -- object into a constituent of the encapsulating state. @@ -28775,9 +28782,19 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; +-- Do not consider generic formals or their corresponding actuals +-- because they are not part of a visible state. Note that both +-- entities are marked as hidden. + +
[Ada] Secondary stack leak in statements block located in a loop
When a loop iterator has a block declaration containing statements that invoke functions whose result is returned on the secondary stack (such as a string-returning function), the compiler fails to generate code to release the allocated memory when the loop terminates. After this patch the following test works fine. with Ada.Text_IO; use Ada.Text_IO; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; pragma Warnings (Off); with System.Secondary_Stack; pragma Warnings (On); procedure Small is procedure Info is new System.Secondary_Stack.Ss_Info (Put_Line); US : Unbounded_String; begin Info; for J in 1 .. 100_000 loop Leaky_Block : declare begin if (J mod 2) = 0 then Info; end if; Ada.Text_IO.Put_Line (To_String (US)); -- Test if (J mod 2) = 0 then Info; end if; end Leaky_Block; end loop; Info; end; Command: gnatmake small.adb; small | grep "Current allocated space :" | uniq Output: Current allocated space : 0 bytes Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * exp_ch7.adb (Make_Transient_Block): When determining whether an enclosing scope already handles the secondary stack, take into account transient blocks nested in a block that do not manage the secondary stack and are located within a loop.--- gcc/ada/exp_ch7.adb +++ gcc/ada/exp_ch7.adb @@ -8695,9 +8695,33 @@ package body Exp_Ch7 is Action : Node_Id; Par: Node_Id) return Node_Id is + function Within_Loop_Statement (N : Node_Id) return Boolean; + -- Return True when N appears within a loop and no block is containing N + function Manages_Sec_Stack (Id : Entity_Id) return Boolean; -- Determine whether scoping entity Id manages the secondary stack + --- + -- Within_Loop_Statement -- + --- + + function Within_Loop_Statement (N : Node_Id) return Boolean is + Par : Node_Id := Parent (N); + + begin + while not (Nkind_In (Par, + N_Loop_Statement, + N_Handled_Sequence_Of_Statements, + N_Package_Specification) + or else Nkind (Par) in N_Proper_Body) + loop +pragma Assert (Present (Par)); +Par := Parent (Par); + end loop; + + return Nkind (Par) = N_Loop_Statement; + end Within_Loop_Statement; + --- -- Manages_Sec_Stack -- --- @@ -8780,6 +8804,16 @@ package body Exp_Ch7 is elsif Ekind (Scop) = E_Loop then exit; +-- Ditto when the block appears without a block that does not +-- manage the secondary stack and is located within a loop. + +elsif Ekind (Scop) = E_Block + and then not Manages_Sec_Stack (Scop) + and then Present (Block_Node (Scop)) + and then Within_Loop_Statement (Block_Node (Scop)) +then + exit; + -- The transient block does not need to manage the secondary stack -- when there is an enclosing construct which already does that. -- This optimization saves on SS_Mark and SS_Release calls but may
[Ada] Spurious error on Part_Of indicator
This patch modifies the verification of a missing Part_Of indicator to avoid considering constants as visible state of a package instantiation because the compiler cannot determine whether their values depend on variable input. This diagnostic is left to GNATprove. -- Source -- -- gnat.adc pragma SPARK_Mode; -- gen_pack.ads generic package Gen_Pack is Val : constant Integer := 123; end Gen_Pack; -- pack.ads with Gen_Pack; package Pack with Abstract_State => Pack_State is procedure Force_Body; private package Inst_1 is new Gen_Pack; -- OK package Inst_2 is new Gen_Pack with Part_Of => Pack_State;-- OK end Pack; -- pack.adb package body Pack with Refined_State => (Pack_State => Inst_2.Val) is procedure Force_Body is null; end Pack; - -- Compilation -- - $ gcc -c pack.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * sem_prag.adb (Has_Visible_State): Do not consider constants as visible state because it is not possible to determine whether a constant depends on variable input. (Propagate_Part_Of): Add comment clarifying the behavior with respect to constant.--- gcc/ada/sem_prag.adb +++ gcc/ada/sem_prag.adb @@ -19991,6 +19991,9 @@ package body Sem_Prag is -- The Part_Of indicator turns an abstract state or an -- object into a constituent of the encapsulating state. + -- Note that constants are considered here even though + -- they may not depend on variable input. This check is + -- left to the SPARK prover. elsif Ekind_In (Item_Id, E_Abstract_State, E_Constant, @@ -28789,12 +28792,12 @@ package body Sem_Prag is elsif Is_Hidden (Item_Id) then null; --- A visible state has been found +-- A visible state has been found. Note that constants are not +-- considered here because it is not possible to determine whether +-- they depend on variable input. This check is left to the SPARK +-- prover. -elsif Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) -then +elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then return True; -- Recursively peek into nested packages and instantiations
[Ada] Avoid confusing warning on exception propagation in GNATprove mode
When compiling with the restriction No_Exception_Propagation, GNAT compiler may issue a warning about exceptions not being propagated. This warning is useless and confusing to users for GNATprove analysis, as GNATprove precisely detects possible exceptions, so disable the warning in that mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Yannick Moy gcc/ada/ * gnat1drv.adb (Gnat1drv): Do not issue warning about exception not being propagated in GNATprove mode.--- gcc/ada/gnat1drv.adb +++ gcc/ada/gnat1drv.adb @@ -467,6 +467,12 @@ procedure Gnat1drv is Ineffective_Inline_Warnings := True; + -- Do not issue warnings for possible propagation of exception. + -- GNATprove already issues messages about possible exceptions. + + No_Warn_On_Non_Local_Exception := True; + Warn_On_Non_Local_Exception := False; + -- Disable front-end optimizations, to keep the tree as close to the -- source code as possible, and also to avoid inconsistencies between -- trees when using different optimization switches.
[Ada] Crash processing abstract state aspect of a package
The compiler may crash processing an aspect Part_Of used in a package spec which has also an Initial_Condition aspect. After this patch the following test compiles fine. package P with SPARK_Mode => On, Abstract_State => (Count_State), Initial_Condition => (Get_Count = 0) -- Test is type Count_Type is range 0 .. 16; function Get_Count return Count_Type; procedure Dummy; private C: Count_Type := 0 with Part_Of => Count_State; -- Test function Get_Count return Count_Type is (C); end P; package body P with SPARK_Mode => On, Refined_State => (Count_State => C) is procedure Dummy is null; end P; Command: gcc -c p.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Javier Miranda gcc/ada/ * exp_ch13.adb (Expand_N_Freeze_Entity): Handle subtype declared for an iterator. * freeze.adb (Freeze_Expression): Handle freeze of an entity defined outside of a subprogram body. This case was previously handled during preanalysis; the frozen entities were remembered and left pending until we continued freezeing entities outside of the subprogram. Now, when climbing the parents chain to locate the correct placement for the freezeing node, we check if the entity can be frozen and only when no enclosing node is marked as Must_Not_Freeze the entity is frozen. * sem_ch3.ads (Preanalyze_Default_Expression): Declaration moved to the package body. * sem_ch3.adb (Preanalyze_Default_Expression): Code adjusted to invoke the new subprogram Preanalyze_With_Freezing_And_Resolve. * sem_ch6.adb (Preanalyze_Formal_Expression): New subprogram. (Analyze_Expression_Function, Process_Formals): Invoke Preanalyze_Formal_Expression instead of Preanalyze_Spec_Expression since the analysis of the formals may freeze entities. (Analyze_Subprogram_Body_Helper): Skip building the body of the class-wide clone for eliminated subprograms. * sem_res.ads, sem_res.adb (Preanalyze_And_Resolve): New subprogram. Its code is basically the previous version of this routine but extended with an additional parameter which is used to specify if during preanalysis we are allowed to freeze entities. If the new parameter is True then the subtree root node is marked as Must_Not_Freeze and no entities are frozen during preanalysis. (Preanalyze_And_Resolve): Invokes the internal version of Preanalyze_And_Resolve without entity freezing. (Preanalyze_With_Freezing_And_Resolve): Invokes the internal version of Prenalyze_And_Resolve with freezing enabled.--- gcc/ada/exp_ch13.adb +++ gcc/ada/exp_ch13.adb @@ -470,6 +470,11 @@ package body Exp_Ch13 is and then Ekind (E_Scope) not in Concurrent_Kind then E_Scope := Scope (E_Scope); + + -- The entity may be a subtype declared for an iterator. + + elsif Ekind (E_Scope) = E_Loop then + E_Scope := Scope (E_Scope); end if; -- Remember that we are processing a freezing entity and its freezing --- gcc/ada/freeze.adb +++ gcc/ada/freeze.adb @@ -6936,20 +6936,6 @@ package body Freeze is --- procedure Freeze_Expression (N : Node_Id) is - In_Spec_Exp : constant Boolean := In_Spec_Expression; - Typ : Entity_Id; - Nam : Entity_Id; - Desig_Typ : Entity_Id; - P : Node_Id; - Parent_P: Node_Id; - - Freeze_Outside : Boolean := False; - -- This flag is set true if the entity must be frozen outside the - -- current subprogram. This happens in the case of expander generated - -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do - -- not freeze all entities like other bodies, but which nevertheless - -- may reference entities that have to be frozen before the body and - -- obviously cannot be frozen inside the body. function Find_Aggregate_Component_Desig_Type return Entity_Id; -- If the expression is an array aggregate, the type of the component @@ -7038,6 +7024,29 @@ package body Freeze is end if; end In_Expanded_Body; + -- Local variables + + In_Spec_Exp : constant Boolean := In_Spec_Expression; + Typ : Entity_Id; + Nam : Entity_Id; + Desig_Typ : Entity_Id; + P : Node_Id; + Parent_P: Node_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be
[Ada] Missing check on illegal equality operation in subprogram
In Ada2012 it is illegal to declare an equality operation on an untagged
type when the operation is primitive and the type is already frozem (see
RM 4.5.2 (9.8)). previously the test to detect this illegality only examined
declarations within a package. This patch covers the case where type and
operation are both declared within a subprogram body.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Ed Schonberg
gcc/ada/
* sem_ch6.adb (Check_Untagged_Equality): Extend check to operations
declared in the same scope as the operand type, when that scope is a
procedure.
gcc/testsuite/
* gnat.dg/equal3.adb: New testcase.--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -8581,14 +8581,10 @@ package body Sem_Ch6 is
if Is_Frozen (Typ) then
- -- If the type is not declared in a package, or if we are in the body
- -- of the package or in some other scope, the new operation is not
- -- primitive, and therefore legal, though suspicious. Should we
- -- generate a warning in this case ???
+ -- The check applies to a primitive operation, so check that type
+ -- and equality operation are in the same scope.
- if Ekind (Scope (Typ)) /= E_Package
- or else Scope (Typ) /= Current_Scope
- then
+ if Scope (Typ) /= Current_Scope then
return;
-- If the type is a generic actual (sub)type, the operation is not
@@ -8631,7 +8627,7 @@ package body Sem_Ch6 is
("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
end if;
--- Otherwise try to find the freezing point
+-- Otherwise try to find the freezing point for better message.
else
Obj_Decl := Next (Parent (Typ));
@@ -8659,6 +8655,13 @@ package body Sem_Ch6 is
end if;
exit;
+
+ -- If we reach generated code for subprogram declaration
+ -- or body, it is the body that froze the type and the
+ -- declaration is legal.
+
+ elsif Sloc (Obj_Decl) = Sloc (Decl) then
+ return;
end if;
Next (Obj_Decl);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/equal3.adb
@@ -0,0 +1,22 @@
+-- { dg-do compile }
+
+procedure Equal3 is
+type R is record
+ A, B : Integer;
+end record;
+
+package Pack is
+ type RR is record
+ C : R;
+ end record;
+
+ X : RR := (C => (A => 1, B => 1));
+ Y : RR := (C => (A => 1, B => 2));
+ pragma Assert (X /= Y); --@ASSERT:PASS
+
+end Pack;
+use Pack;
+function "=" (X, Y : R) return Boolean is (X.A = Y.A); -- { dg-error "equality operator must be declared before type \"R\" is frozen \\(RM 4.5.2 \\(9.8\\)\\) \\(Ada 2012\\)" }
+begin
+pragma Assert (X /= Y); --@ASSERT:FAIL
+end Equal3;
[Ada] Argument_String_To_List creates empty items from whitespace
This patch corrects an issue whereby leading whitespace in a non-quoted argument list passed to Argument_String_To_List caused extraneous empty arguments to be returned. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Justin Squirek gcc/ada/ * libgnat/s-os_lib.adb (Argument_String_To_List): Fix trimming of whitespace. gcc/testsuite/ * gnat.dg/split_args.adb: New testcase.--- gcc/ada/libgnat/s-os_lib.adb +++ gcc/ada/libgnat/s-os_lib.adb @@ -178,7 +178,6 @@ package body System.OS_Lib is return Len; end Args_Length; - - -- Argument_String_To_List -- - @@ -191,6 +190,9 @@ package body System.OS_Lib is Idx : Integer; New_Argc : Natural := 0; + Backqd : Boolean := False; + Quoted : Boolean := False; + Cleaned : String (1 .. Arg_String'Length); Cleaned_Idx : Natural; -- A cleaned up version of the argument. This function is taking @@ -205,75 +207,71 @@ package body System.OS_Lib is Idx := Arg_String'First; loop - exit when Idx > Arg_String'Last; + -- Skip extraneous spaces - declare -Backqd : Boolean := False; -Quoted : Boolean := False; - - begin -Cleaned_Idx := Cleaned'First; + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop +Idx := Idx + 1; + end loop; -loop - -- An unquoted space is the end of an argument + exit when Idx > Arg_String'Last; - if not (Backqd or Quoted) - and then Arg_String (Idx) = ' ' - then - exit; + Cleaned_Idx := Cleaned'First; + Backqd := False; + Quoted := False; - -- Start of a quoted string + loop +-- An unquoted space is the end of an argument - elsif not (Backqd or Quoted) - and then Arg_String (Idx) = '"' - then - Quoted := True; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; +if not (Backqd or Quoted) + and then Arg_String (Idx) = ' ' +then + exit; - -- End of a quoted string and end of an argument +-- Start of a quoted string - elsif (Quoted and not Backqd) - and then Arg_String (Idx) = '"' - then - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - Idx := Idx + 1; - exit; +elsif not (Backqd or Quoted) + and then Arg_String (Idx) = '"' +then + Quoted := True; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - -- Turn off backquoting after advancing one character +-- End of a quoted string and end of an argument - elsif Backqd then - Backqd := False; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; +elsif (Quoted and not Backqd) + and then Arg_String (Idx) = '"' +then + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + Idx := Idx + 1; + exit; - -- Following character is backquoted +-- Turn off backquoting after advancing one character - elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then - Backqd := True; +elsif Backqd then + Backqd := False; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - else - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - end if; +-- Following character is backquoted - Idx := Idx + 1; - exit when Idx > Arg_String'Last; -end loop; +elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then + Backqd := True; --- Found an argument +else + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; +end if; -New_Argc := New_Argc + 1; -New_Argv (New_Argc) := - new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); +Idx := Idx + 1; +exit when Idx > Arg_String'Last; + end loop; --- Skip extraneous spaces + -- Found an argument -while Idx <= Arg_String'Last and th
[Ada] Minor fix for imported C++ constructors
C++ constructors are imported as functions and then internally rewritten into procedures taking the "this" pointer as first parameter. Now this parameter is not of an access type but of the type directly, so it must be In/Out and not just In. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Eric Botcazou gcc/ada/ * exp_disp.adb (Gen_Parameters_Profile): Make the _Init parameter an In/Out parameter. (Set_CPP_Constructors): Adjust comment accordingly.--- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -8181,7 +8181,8 @@ package body Exp_Disp is function Gen_Parameters_Profile (E : Entity_Id) return List_Id; -- Duplicate the parameters profile of the imported C++ constructor - -- adding an access to the object as an additional parameter. + -- adding the "this" pointer to the object as the additional first + -- parameter under the usual form _Init : in out Typ. -- Gen_Parameters_Profile -- @@ -8198,6 +8199,8 @@ package body Exp_Disp is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, Parameter_Type => New_Occurrence_Of (Typ, Loc))); if Present (Parameter_Specifications (Parent (E))) then @@ -8244,9 +8247,7 @@ package body Exp_Disp is Found := True; Loc := Sloc (E); Parms := Gen_Parameters_Profile (E); -IP:= - Make_Defining_Identifier (Loc, -Chars => Make_Init_Proc_Name (Typ)); +IP:= Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); -- Case 1: Constructor of untagged type @@ -8273,14 +8274,14 @@ package body Exp_Disp is -- Case 2: Constructor of a tagged type --- In this case we generate the IP as a wrapper of the the --- C++ constructor because IP must also save copy of the _tag +-- In this case we generate the IP routine as a wrapper of the +-- C++ constructor because IP must also save a copy of the _tag -- generated in the C++ side. The copy of the _tag is used by -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. -- Generate: --- procedure IP (_init : Typ; ...) is ---procedure ConstructorP (_init : Typ; ...); +-- procedure IP (_init : in out Typ; ...) is +--procedure ConstructorP (_init : in out Typ; ...); --pragma Import (ConstructorP); -- begin --ConstructorP (_init, ...); @@ -8352,7 +8353,7 @@ package body Exp_Disp is loop -- Skip the following assertion with primary tags -- because Related_Type is not set on primary tag --- components +-- components. pragma Assert (Tag_Comp = First_Tag_Component (Typ)
[Ada] Assertion_Policy for class-wide precondition
This patch fixes the compiler to that class-wide preconditions on primitive operations of interfaces are not checked at run time when the Assertion_Policy indicates that they should be ignored. This is required by the RM. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Bob Duff gcc/ada/ * exp_disp.adb (Build_Class_Wide_Check): Return early if the precondition is supposed to be ignored.--- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -809,7 +809,7 @@ package body Exp_Disp is Prec := Next_Pragma (Prec); end loop; -if No (Prec) then +if No (Prec) or else Is_Ignored (Prec) then return; end if;
[Ada] Configuration state not observed for instance bodies
This patch ensures that the processing of instantiated and inlined bodies uses the proper configuration context available at the point of the instantiation or inlining. Previously configuration pragmas which appear prior to the context items of a unit would lose their effect when a body is instantiated or inlined. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * frontend.adb (Frontend): Update the call to Register_Config_Switches. * inline.ads: Add new component Config_Switches to record Pending_Body_Info which captures the configuration state of the pending body. Remove components Version, Version_Pragma, SPARK_Mode, and SPARK_Mode_Pragma from record Pending_Body_Info because they are already captured in component Config_Switches. * opt.adb (Register_Opt_Config_Switches): Rename to Register_Config_Switches. (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This routine is now a function, and returns the saved configuration state as an aggregate to avoid missing an attribute. (Set_Opt_Config_Switches): Rename to Set_Config_Switches. * opt.ads (Register_Opt_Config_Switches): Rename to Register_Config_Switches. (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This routine is now a function. (Set_Opt_Config_Switches): Rename to Set_Config_Switches. * par.adb (Par): Update the calls to configuration switch-related subprograms. * sem.adb (Semantics): Update the calls to configuration switch-related subprograms. * sem_ch10.adb (Analyze_Package_Body_Stub): Update the calls to configuration switch-related subprograms. (Analyze_Protected_Body_Stub): Update the calls to configuration switch-related subprograms. (Analyze_Subprogram_Body_Stub): Update calls to configuration switch-related subprograms. * sem_ch12.adb (Add_Pending_Instantiation): Update the capture of pending instantiation attributes. (Inline_Instance_Body): Update the capture of pending instantiation attributes. It is no longer needed to explicitly manipulate the SPARK mode. (Instantiate_Package_Body): Update the restoration of the context attributes. (Instantiate_Subprogram_Body): Update the restoration of context attributes. (Load_Parent_Of_Generic): Update the capture of pending instantiation attributes. (Set_Instance_Env): Update the way relevant configuration attributes are saved and restored. gcc/testsuite/ * gnat.dg/config_pragma1.adb, gnat.dg/config_pragma1_pkg.ads: New testcase.--- gcc/ada/frontend.adb +++ gcc/ada/frontend.adb @@ -303,7 +303,7 @@ begin -- capture the values of the configuration switches (see Opt for further -- details). - Opt.Register_Opt_Config_Switches; + Register_Config_Switches; -- Check for file which contains No_Body pragma --- gcc/ada/inline.ads +++ gcc/ada/inline.ads @@ -63,21 +63,24 @@ package Inline is -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record - Inst_Node : Node_Id; - -- Node for instantiation that requires the body - Act_Decl : Node_Id; -- Declaration for package or subprogram spec for instantiation - Expander_Status : Boolean; - -- If the body is instantiated only for semantic checking, expansion - -- must be inhibited. + Config_Switches : Config_Switches_Type; + -- Capture the values of configuration switches Current_Sem_Unit : Unit_Number_Type; -- The semantic unit within which the instantiation is found. Must be -- restored when compiling the body, to insure that internal entities -- use the same counter and are unique over spec and body. + Expander_Status : Boolean; + -- If the body is instantiated only for semantic checking, expansion + -- must be inhibited. + + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to @@ -93,21 +96,8 @@ package Inline is -- This means we have to capture this information from the current scope -- at the point of instantiation. - Version : Ada_Version_Type; - -- The body must be compiled with the same language version as the - -- spec. The version may be set by a configuration pragma in a separate - -- file or in the current file, and may differ from body to body. - - Versio
[Ada] Use standard version of s-memory.adb for mingw32
This patch switches mingw32 targets to use the standard version of s-memory.adb as Windows now has the capability of limiting the amount of memory used by process. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Patrick Bernardi gcc/ada/ * libgnat/s-memory__mingw.adb: Remove. * Makefile.rtl: Remove s-memory.adb target pair from the Cygwin/Mingw32 section. gcc/testsuite/ * gnat.dg/memorytest.adb: New testcase.--- gcc/ada/Makefile.rtl +++ gcc/ada/Makefile.rtl @@ -1960,19 +1960,17 @@ endif # Cygwin/Mingw32 ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) # Cygwin provides a full Posix environment, and so we use the default - # versions of s-memory and g-socthi rather than the Windows-specific - # MinGW versions. Ideally we would use all the default versions for - # Cygwin and none of the MinGW versions, but for historical reasons - # the Cygwin port has always been a CygMing frankenhybrid and it is - # a long-term project to disentangle them. + # versions g-socthi rather than the Windows-specific MinGW version. + # Ideally we would use all the default versions for Cygwin and none + # of the MinGW versions, but for historical reasons the Cygwin port + # has always been a CygMing frankenhybrid and it is a long-term project + # to disentangle them. ifeq ($(strip $(filter-out cygwin%,$(target_os))),) LIBGNAT_TARGET_PAIRS = \ -s-memory.adbhttp://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- --- - --- This version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - --- - -- Alloc -- - --- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); -
[Ada] Faulty ignored Ghost code removal
This patch ensures that removal of ignored Ghost code is the absolute last operation performed on the tree. Previously the removal was performed prior to issuing delayed warnings, however the warning mechanism may see a heavily modified tree and fail. No small reproducer available. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Hristian Kirtchev gcc/ada/ * frontend.adb (Frontend): The removal of ignored Ghost code must be the last semantic operation performed on the tree.--- gcc/ada/frontend.adb +++ gcc/ada/frontend.adb @@ -451,11 +451,6 @@ begin Check_Elaboration_Scenarios; - -- Remove any ignored Ghost code as it must not appear in the - -- executable. - - Remove_Ignored_Ghost_Code; - -- Examine all top level scenarios collected during analysis and -- resolution in order to diagnose conditional ABEs, even in the -- presence of serious errors. @@ -483,6 +478,14 @@ begin Sem_Warn.Output_Unreferenced_Messages; Sem_Warn.Check_Unused_Withs; Sem_Warn.Output_Unused_Warnings_Off_Warnings; + +-- Remove any ignored Ghost code as it must not appear in the +-- executable. This action must be performed last because it +-- heavily alters the tree. + +if Operating_Mode = Generate_Code or else GNATprove_Mode then + Remove_Ignored_Ghost_Code; +end if; end if; end if; end;
[Ada] Fix incompatibility Default_Scalar_Storage_Order/tagged types
The pragma Default_Scalar_Storage_Order cannot reliably be used to set the
non-default scalar storage order for a program that declares tagged types, if
it also declares user-defined primitives.
This is fixed by making Make_Tags use the same base array type as Make_DT and
Make_Secondary_DT when accessing the array of user-defined primitives.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Eric Botcazou
gcc/ada/
* exp_disp.adb (Make_Tags): When the type has user-defined primitives,
build the access type that is later used by Build_Get_Prim_Op_Address
as pointing to a subtype of Ada.Tags.Address_Array.
gcc/testsuite/
* gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase.--- gcc/ada/exp_disp.adb
+++ gcc/ada/exp_disp.adb
@@ -7179,7 +7179,7 @@ package body Exp_Disp is
Analyze_List (Result);
-- Generate:
- -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
+ -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
-- type Typ_DT_Acc is access Typ_DT;
else
@@ -7196,20 +7196,19 @@ package body Exp_Disp is
Name_DT_Prims_Acc);
begin
Append_To (Result,
- Make_Full_Type_Declaration (Loc,
+ Make_Subtype_Declaration (Loc,
Defining_Identifier => DT_Prims,
-Type_Definition =>
- Make_Constrained_Array_Definition (Loc,
-Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
-Low_Bound => Make_Integer_Literal (Loc, 1),
-High_Bound => Make_Integer_Literal (Loc,
- DT_Entry_Count
- (First_Tag_Component (Typ),
-Component_Definition =>
- Make_Component_Definition (Loc,
-Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc);
+Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Address_Array), Loc),
+Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, New_List (
+Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc,
+ DT_Entry_Count
+ (First_Tag_Component (Typ);
Append_To (Result,
Make_Full_Type_Declaration (Loc,
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/sso10.adb
@@ -0,0 +1,16 @@
+-- { dg-do run }
+
+with SSO10_Pkg; use SSO10_Pkg;
+
+procedure SSO10 is
+
+ procedure Inner (R : Root'Class) is
+ begin
+Run (R);
+ end;
+
+ R : Root;
+
+begin
+ Inner (R);
+end;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/sso10_pkg.ads
@@ -0,0 +1,9 @@
+pragma Default_Scalar_Storage_Order (High_Order_First);
+
+package SSO10_Pkg is
+
+ type Root is tagged null record;
+
+ procedure Run (R : Root) is null;
+
+end SSO10_Pkg;
[Ada] Spurious error on prefixed call in an instantiation
This patch fixes a spurious error on a prefixed call in an instance, when the generic parameters include an interface type and an abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. The patch also fixes a similar error involving class-wide operations and generic private types. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Ed Schonberg gcc/ada/ * sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call in an instance, when the generic parameters include an interface type and a abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. gcc/testsuite/ * gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New testcase.--- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -8928,11 +8928,38 @@ package body Sem_Ch4 is (Anc_Type : Entity_Id; Error: out Boolean) is +Candidate : Entity_Id; +-- If homonym is a renaming, examine the renamed program + Cls_Type: Entity_Id; Hom : Entity_Id; Hom_Ref : Node_Id; Success : Boolean; +function First_Formal_Match + (Typ : Entity_Id) return Boolean; +-- Predicate to verify that the first formal of a class-wide +-- candidate matches the type of the prefix. + + +-- First_Formal_Match -- + + +function First_Formal_Match + (Typ : Entity_Id) return Boolean +is + Ctrl : constant Entity_Id := First_Formal (Candidate); +begin + return Present (Ctrl) + and then + (Base_Type (Etype (Ctrl)) = Typ + or else + (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type + and then + Base_Type +(Designated_Type (Etype (Ctrl))) = Typ)); +end First_Formal_Match; + begin Error := False; @@ -8948,25 +8975,23 @@ package body Sem_Ch4 is while Present (Hom) loop if Ekind_In (Hom, E_Procedure, E_Function) - and then (not Is_Hidden (Hom) or else In_Instance) - and then Scope (Hom) = Scope (Base_Type (Anc_Type)) - and then Present (First_Formal (Hom)) - and then - (Base_Type (Etype (First_Formal (Hom))) = Cls_Type - or else - (Is_Access_Type (Etype (First_Formal (Hom))) - and then - Ekind (Etype (First_Formal (Hom))) = - E_Anonymous_Access_Type - and then - Base_Type - (Designated_Type (Etype (First_Formal (Hom = - Cls_Type)) + and then Present (Renamed_Entity (Hom)) + and then Is_Generic_Actual_Subprogram (Hom) + then + Candidate := Renamed_Entity (Hom); + else + Candidate := Hom; + end if; + + if Ekind_In (Candidate, E_Procedure, E_Function) + and then (not Is_Hidden (Candidate) or else In_Instance) + and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) + and then First_Formal_Match (Cls_Type) then -- If the context is a procedure call, ignore functions -- in the name of the call. - if Ekind (Hom) = E_Function + if Ekind (Candidate) = E_Function and then Nkind (Parent (N)) = N_Procedure_Call_Statement and then N = Name (Parent (N)) then @@ -8975,7 +9000,7 @@ package body Sem_Ch4 is -- If the context is a function call, ignore procedures -- in the name of the call. - elsif Ekind (Hom) = E_Procedure + elsif Ekind (Candidate) = E_Procedure and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then goto Next_Hom; @@ -8986,7 +9011,7 @@ package body Sem_Ch4 is Success := False; if No (Matching_Op) then - Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog)); + Hom_Ref
[Ada] Spurious error -- "allocation from empty storage pool"
This patch fixes a bug in which if "pragma Default_Storage_Pool (null);"
is given, then a build-in-place function will get an incorrect error
message "allocation from empty storage pool" even though there is no
such allocation in the source program.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Bob Duff
gcc/ada/
* sem_res.adb (Resolve_Allocator): Do not complain about the
implicit allocator that occurs in the expansion of a return
statement for a build-in-place function.--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -5035,9 +5035,14 @@ package body Sem_Res is
end;
end if;
- -- Check for allocation from an empty storage pool
+ -- Check for allocation from an empty storage pool. But do not complain
+ -- if it's a return statement for a build-in-place function, because the
+ -- allocator is there just in case the caller uses an allocator. If the
+ -- caller does use an allocator, it will be caught at the call site.
- if No_Pool_Assigned (Typ) then
+ if No_Pool_Assigned (Typ)
+and then not Alloc_For_BIP_Return (N)
+ then
Error_Msg_N ("allocation from empty storage pool!", N);
-- If the context is an unchecked conversion, as may happen within an
[Ada] Deconstruct 'F' as a prefix for an ALI data
In GNATprove we used to store a variant of cross-reference information in
the ALI file in lines that started with an 'F' letter. This is no longer
the case, so the letter can be returned to the pool of unused prefixes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Piotr Trojanek
gcc/ada/
* ali.adb (Known_ALI_Lines): Remove 'F' as a prefix for lines
related to the FORMAL analysis done by GNATprove.--- gcc/ada/ali.adb
+++ gcc/ada/ali.adb
@@ -39,7 +39,7 @@ package body ALI is
-- line type markers in the ALI file. This is used in Scan_ALI to detect
-- (or skip) invalid lines. The following letters are still available:
--
- --B G H J K O Q Z
+ --B F G H J K O Q Z
Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
('V'=> True, -- version
@@ -59,7 +59,6 @@ package body ALI is
'Y'=> True, -- limited_with
'Z'=> True, -- implicit with from instantiation
'C'=> True, -- SCO information
- 'F'=> True, -- SPARK cross-reference information
'T'=> True, -- task stack information
others => False);
[Ada] Spurious warning on iteration over range of 64-bit modular type
This patch suppresses a spurious warning on the use of a 64-bit modular type
in a quantified expression, where the range of iteration will include a bound
that appears larger than the run-time representation of Universal_Integer'last.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Ed Schonberg
gcc/ada/
* sem_eval.adb (Check_Non_Static_Context): Do not warn on an
integer literal greater than the upper bound of
Universal_Integer'Last when expansion is disabled, to avoid a
spurious warning over ranges involving 64-bit modular types.
gcc/testsuite/
* gnat.dg/iter3.adb: New testcase.--- gcc/ada/sem_eval.adb
+++ gcc/ada/sem_eval.adb
@@ -547,9 +547,15 @@ package body Sem_Eval is
-- called in contexts like the expression of a number declaration where
-- we certainly want to allow out of range values.
+ -- We inhibit the warning when expansion is disabled, because the
+ -- preanalysis of a range of a 64-bit modular type may appear to
+ -- violate the constraint on non-static Universal_Integer. If there
+ -- is a true overflow it will be diagnosed during full analysis.
+
if Etype (N) = Universal_Integer
and then Nkind (N) = N_Integer_Literal
and then Nkind (Parent (N)) in N_Subexpr
+and then Expander_Active
and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/iter3.adb
@@ -0,0 +1,15 @@
+-- { dg-do compile }
+-- { dg-options "-gnata" }
+
+procedure Iter3 is
+ type Mod64 is mod 2 ** 64;
+
+ function F (X : Mod64) return Boolean is (X /= Mod64'Last);
+begin
+ pragma Assert (for all X in Mod64 => F(X));
+ pragma Assert (for all X in Mod64'Range => F(X));
+
+ for X in Mod64'Range loop
+ null;
+ end loop;
+end;
[Ada] Replace low-level calls to Ekind with high-level calls to Is_Formal
High-level wrappers are easier to read. This change came up while reading some code related to GNATprove, but then uniformly applied to the entire frontend. For the few remaining membership tests that could be replaced by Is_Formal it is not obvious whether the high-level routine makes the code better. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Piotr Trojanek gcc/ada/ * exp_aggr.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb, repinfo.adb, sem_ch9.adb: Minor replace Ekind membership tests with a wrapper routine.--- gcc/ada/exp_aggr.adb +++ gcc/ada/exp_aggr.adb @@ -7278,7 +7278,7 @@ package body Exp_Aggr is (Nkind (Expr_Q) = N_Type_Conversion or else (Is_Entity_Name (Expr_Q) - and then Ekind (Entity (Expr_Q)) in Formal_Kind)) + and then Is_Formal (Entity (Expr_Q and then Tagged_Type_Expansion then Static_Components := False; --- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -12547,7 +12547,7 @@ package body Exp_Ch4 is Sel_Comp := Parent (Sel_Comp); end loop; - return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; + return Is_Formal (Entity (Prefix (Sel_Comp))); end Prefix_Is_Formal_Parameter; -- Start of processing for Has_Inferable_Discriminants --- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -6799,7 +6799,7 @@ package body Exp_Ch6 is and then (Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind)) + and then Is_Formal (Entity (Exp then -- When the return type is limited, perform a check that the tag of -- the result is the same as the tag of the return type. @@ -6877,7 +6877,7 @@ package body Exp_Ch6 is or else Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind) + and then Is_Formal (Entity (Exp))) or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) then --- gcc/ada/lib-xref.adb +++ gcc/ada/lib-xref.adb @@ -1034,7 +1034,7 @@ package body Lib.Xref is -- parameters may end up being marked as not coming from source -- although they are. Take these into account specially. - elsif GNATprove_Mode and then Ekind (E) in Formal_Kind then + elsif GNATprove_Mode and then Is_Formal (E) then Ent := E; -- Entity does not come from source, but is a derived subprogram and --- gcc/ada/repinfo.adb +++ gcc/ada/repinfo.adb @@ -428,7 +428,7 @@ package body Repinfo is List_Entities (E, Bytes_Big_Endian, True); - elsif Ekind (E) in Formal_Kind and then In_Subprogram then + elsif Is_Formal (E) and then In_Subprogram then null; elsif Ekind_In (E, E_Entry, --- gcc/ada/sem_ch9.adb +++ gcc/ada/sem_ch9.adb @@ -2358,7 +2358,7 @@ package body Sem_Ch9 is if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) - or else Ekind (Entity (Target_Obj)) not in Formal_Kind + or else not Is_Formal (Entity (Target_Obj)) or else Enclosing /= Scope (Entity (Target_Obj))) then Error_Msg_N
[Ada] Compiler failure on an extended_return_statement in a block
When compiling with an assertion-enabled compiler, Assert_Failure can be
raised when expanded an extended_return_statement whose enclosing scope
is not a function (such as when it's a block_statement). The simple fix
is to change the Assert to test Current_Subprogram rather than Current_Scope.
Three such Assert pragmas are corrected in this way.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Gary Dismukes
gcc/ada/
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace
calls to Current_Scope in three assertions with calls to
Current_Subprogram.
gcc/testsuite/
* gnat.dg/block_ext_return_assert_failure.adb: New testcase.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -4763,7 +4763,7 @@ package body Exp_Ch6 is
-- the pointer to the object) they are always handled by means of
-- simple return statements.
- pragma Assert (not Is_Thunk (Current_Scope));
+ pragma Assert (not Is_Thunk (Current_Subprogram));
if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
Exp := Expression (Ret_Obj_Decl);
@@ -4772,9 +4772,9 @@ package body Exp_Ch6 is
-- then F and G are both b-i-p, or neither b-i-p.
if Nkind (Exp) = N_Function_Call then
-pragma Assert (Ekind (Current_Scope) = E_Function);
+pragma Assert (Ekind (Current_Subprogram) = E_Function);
pragma Assert
- (Is_Build_In_Place_Function (Current_Scope) =
+ (Is_Build_In_Place_Function (Current_Subprogram) =
Is_Build_In_Place_Function_Call (Exp));
null;
end if;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/block_ext_return_assert_failure.adb
@@ -0,0 +1,24 @@
+-- { dg-do compile }
+
+-- This test used to crash a compiler with assertions enabled
+
+procedure Block_Ext_Return_Assert_Failure is
+
+ function Return_Int return Integer is
+ begin
+ return 123;
+ end Return_Int;
+
+ function F return Integer is
+ begin
+ declare
+ begin
+ return Result : constant Integer := Return_Int do
+null;
+ end return;
+ end;
+ end F;
+
+begin
+ null;
+end Block_Ext_Return_Assert_Failure;
[Ada] Spurious error on the placement of aspect Global
This patch modifies the expansion of stand-alone subprogram bodies that appear in the body of a protected type to properly associate aspects and pragmas to the newly created spec for the subprogram body. As a result, the annotations are properly associated with the initial declaration of the subprogram. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Hristian Kirtchev gcc/ada/ * exp_ch9.adb (Analyze_Pragmas): New routine. (Build_Private_Protected_Declaration): Code clean up. Relocate relevant aspects and pragmas from the stand-alone body to the newly created spec. Explicitly analyze any pragmas that have been either relocated or produced by the analysis of the aspects. (Move_Pragmas): New routine. * sem_prag.adb (Find_Related_Declaration_Or_Body): Recognize the case where a pragma applies to the internally created spec for a stand-along subprogram body declared in a protected body. gcc/testsuite/ * gnat.dg/global.adb, gnat.dg/global.ads: New testcase.--- gcc/ada/exp_ch9.adb +++ gcc/ada/exp_ch9.adb @@ -23,6 +23,7 @@ -- -- -- +with Aspects; use Aspects; with Atree;use Atree; with Einfo;use Einfo; with Elists; use Elists; @@ -53,6 +54,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo;use Sinfo; @@ -290,7 +292,7 @@ package body Exp_Ch9 is (N : Node_Id; Pid : Node_Id) return Node_Id; -- This routine constructs the unprotected version of a protected - -- subprogram body, which is contains all of the code in the original, + -- subprogram body, which contains all of the code in the original, -- unexpanded body. This is the version of the protected subprogram that is -- called from all protected operations on the same object, including the -- protected version of the same subprogram. @@ -3483,14 +3485,95 @@ package body Exp_Ch9 is function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From + + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body From's + -- declarations and insert them after arbitrary node To. + + - + -- Analyze_Pragmas -- + - + + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; + + begin + Decl := Next (From); + while Present (Decl) loop +if Nkind (Decl) = N_Pragma then + Analyze_Pragma (Decl); + +-- No candidate pragmas are available for analysis + +else + exit; +end if; + +Next (Decl); + end loop; + end Analyze_Pragmas; + + -- + -- Move_Pragmas -- + -- + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + +-- Preserve the following declaration for iteration purposes, due +-- to possible relocation of a pragma. + +Next_Decl := Next (Decl); + +if Nkind (Decl) = N_Pragma then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + +-- Skip internally generated code + +elsif not Comes_From_Source (Decl) then + null; + +-- No candidate pragmas are available for relocation + +else + exit; +end if; + +Decl := Next_Decl; + end loop; + end Move_Pragmas; + + -- Local variables + + Body_Id : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (N); - Body_Id : constant Entity_Id := Defining_Entity (N); Decl : Node_Id; - Plist: List_Id; Formal : Entity_Id; - New_Spec : Node_Id; + Formals : List_Id; + Spec : Node_Id; Spec_Id : Entity_Id; + -- Start of processing for Build_Private_Protected_Declaration + begin Formal := F
[Ada] Wrong value after assignment of overlain record objects
This patch corrects an issue whereby objects of a record type with a
representation clause which are overlain by address would fail to get
assigned values properly when one or both of said objects were marked
volatile.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Justin Squirek
gcc/ada/
* exp_ch5.adb (Make_Field_Assign): Force temporarily generated
objects for assignment of overlaid user objects to be renamings
instead of constant declarations.
gcc/testsuite/
* gnat.dg/addr11.adb: New testcase.--- gcc/ada/exp_ch5.adb
+++ gcc/ada/exp_ch5.adb
@@ -1531,11 +1531,22 @@ package body Exp_Ch5 is
Selector_Name => New_Occurrence_Of (Disc, Loc));
end if;
+-- Generate the assignment statement. When the left-hand side
+-- is an object with an address clause present, force generated
+-- temporaries to be renamings so as to correctly assign to any
+-- overlaid objects.
+
A :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
-Prefix=> Duplicate_Subexpr (Lhs),
+Prefix=>
+ Duplicate_Subexpr
+(Exp => Lhs,
+ Name_Req => False,
+ Renaming_Req =>
+ Is_Entity_Name (Lhs)
+ and then Present (Address_Clause (Entity (Lhs,
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
Expression => Expr);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/addr11.adb
@@ -0,0 +1,28 @@
+-- { dg-do run }
+
+procedure Addr11 is
+
+ type Rec is record
+I : Short_Integer;
+C : Character;
+ end record;
+
+ type Derived is new Rec;
+ for Derived use record
+I at 1 range 0 .. 15;
+C at 0 range 0 .. 7;
+ end record;
+
+ Init : constant Rec := ( 1515, 'A' );
+
+ D1 : Derived;
+ D2 : Derived;
+ pragma Volatile (D2);
+ for D2'Address use D1'Address;
+
+begin
+ D2 := Derived (Init);
+ if D1 /= Derived (Init) then
+raise Program_Error;
+ end if;
+end;
[Ada] Fix alignment of mutex_t and cond_t type on 32-bit SPARC/Solaris
The alignment of the couple of types from System.OS_Interface was wrongly set to 4 (32-bit) instead of 8 (64-bit) in 32-bit mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Eric Botcazou gcc/ada/ * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. (mutex_t): Use it for 'lock' and 'data' components. (cond_t): Likewise for 'data' and use single 'flags' component.--- gcc/ada/libgnarl/s-osinte__solaris.ads +++ gcc/ada/libgnarl/s-osinte__solaris.ads @@ -536,17 +536,18 @@ private end record; pragma Convention (C, record_type_3); + type upad64_t is new Interfaces.Unsigned_64; + type mutex_t is record flags : record_type_3; - lock : String (1 .. 8); - data : String (1 .. 8); + lock : upad64_t; + data : upad64_t; end record; pragma Convention (C, mutex_t); type cond_t is record - flag : array_type_9; - Xtype : unsigned_long; - data : String (1 .. 8); + flags : record_type_3; + data : upad64_t; end record; pragma Convention (C, cond_t);
[Ada] Spurious error on default parameter in protected operation
This patch fixes a spurious compiler error on a call to a protected
operation whose profile includes a defaulted in-parameter that is a call
to another protected function of the same object.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Ed Schonberg
gcc/ada/
* exp_ch6.adb (Expand_Protected_Subprogram_Call): Handle
properly a protected call that includes a default parameter that
is a call to a protected function of the same type.
gcc/testsuite/
* gnat.dg/prot5.adb, gnat.dg/prot5_pkg.adb,
gnat.dg/prot5_pkg.ads: New testcase.--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -6387,6 +6387,30 @@ package body Exp_Ch6 is
then
Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
+ -- A default parameter of a protected operation may be a call to
+ -- a protected function of the type. This appears as an internal
+ -- call in the profile of the operation, but if the context is an
+ -- external call we must convert the call into an external one,
+ -- using the protected object that is the target, so that:
+
+ -- Prot.P (F)
+ -- is transformed into
+ -- Prot.P (Prot.F)
+
+ elsif Nkind (Parent (N)) = N_Procedure_Call_Statement
+ and then Nkind (Name (Parent (N))) = N_Selected_Component
+ and then Is_Protected_Type (Etype (Prefix (Name (Parent (N)
+ and then Is_Entity_Name (Name (N))
+ and then Scope (Entity (Name (N))) =
+ Etype (Prefix (Name (Parent (N
+ then
+Rewrite (Name (N),
+ Make_Selected_Component (Sloc (N),
+Prefix => New_Copy_Tree (Prefix (Name (Parent (N,
+Selector_Name => Relocate_Node (Name (N;
+Analyze_And_Resolve (N);
+return;
+
else
-- If the context is the initialization procedure for a protected
-- type, the call is legal because the called entity must be a
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5.adb
@@ -0,0 +1,12 @@
+-- { dg-do run }
+-- { dg-options -gnata }
+
+with Prot5_Pkg;
+
+procedure Prot5 is
+begin
+ Prot5_Pkg.P.Proc (10); -- explicit parameter
+ Prot5_Pkg.P.Proc (Prot5_Pkg.P.Get_Data); -- explicit call to protected operation
+ Prot5_Pkg.P.Proc;-- defaulted call.
+ pragma Assert (Prot5_Pkg.P.Get_Data = 80);
+end Prot5;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5_pkg.adb
@@ -0,0 +1,13 @@
+package body Prot5_Pkg is
+ protected body P is
+ function Get_Data return Integer is
+ begin
+ return Data;
+ end Get_Data;
+
+ procedure Proc (A : Integer := Get_Data) is
+ begin
+ Data := A * 2;
+ end Proc;
+ end P;
+end Prot5_Pkg;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/prot5_pkg.ads
@@ -0,0 +1,8 @@
+package Prot5_Pkg is
+ protected P is
+ function Get_Data return Integer;
+ procedure Proc (A : Integer := Get_Data);
+ private
+ Data : Integer;
+ end P;
+end Prot5_Pkg;
[Ada] GNATmake fails to detect missing body
This patch corrects an issue whereby building a multi-unit compilation with missing sources resulted in a cryptic "code generation" error instead of the appropriate file not found error. -- Source -- -- main.adb with Types; procedure Main is begin null; end; -- types.ads package Types is procedure Force; end; -- Compilation and output -- & gnatmake -q main.adb gnatmake: "types.adb" not found Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Justin Squirek gcc/ada/ * lib-writ.adb (Write_With_Lines): Modfiy the generation of dependencies within ali files so that source unit bodies are properly listed even if said bodies are missing. Perform legacy behavior in GNATprove mode. * lib-writ.ads: Modify documentation to reflect current behavior.--- gcc/ada/lib-writ.adb +++ gcc/ada/lib-writ.adb @@ -950,20 +950,35 @@ package body Lib.Writ is Write_Info_Tab (25); if Is_Spec_Name (Uname) then - Body_Fname := -Get_File_Name - (Get_Body_Name (Uname), - Subunit => False, May_Fail => True); - - Body_Index := -Get_Unit_Index - (Get_Body_Name (Uname)); - - if Body_Fname = No_File then - Body_Fname := Get_File_Name (Uname, Subunit => False); - Body_Index := Get_Unit_Index (Uname); - end if; + -- In GNATprove mode we must write the spec of a unit which + -- requires a body if that body is not found. This will + -- allow partial analysis on incomplete sources. + + if GNATprove_Mode then + + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => True); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + + if Body_Fname = No_File then +Body_Fname := Get_File_Name (Uname, Subunit => False); +Body_Index := Get_Unit_Index (Uname); + end if; + + -- In the normal path we don't allow failure in fetching the + -- name of the desired body unit so that it may be properly + -- referenced in the output ali - even if it is missing. + + else + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => False); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + end if; else Body_Fname := Get_File_Name (Uname, Subunit => False); Body_Index := Get_Unit_Index (Uname); --- gcc/ada/lib-writ.ads +++ gcc/ada/lib-writ.ads @@ -629,13 +629,13 @@ package Lib.Writ is -- by the current unit. One Z line is present for each unit that is -- only implicitly withed by the current unit. The first parameter is -- the unit name in internal format. The second parameter is the file - -- name of the file that must be compiled to compile this unit. It is - -- usually the file for the body, except for packages which have no - -- body. For units that need a body, if the source file for the body - -- cannot be found, the file name of the spec is used instead. The - -- third parameter is the file name of the library information file - -- that contains the results of compiling this unit. The optional - -- modifiers are used as follows: + -- name of the body unit on which the current compliation depends - + -- except when in GNATprove mode. In GNATprove mode, when packages + -- which require a body have no associated source file, the file name + -- of the spec is used instead to allow partial analysis of incomplete + -- sources. The third parameter is the file name of the library + -- information file that contains the results of compiling this unit. + -- The optional modifiers are used as follows: --E pragma Elaborate applies to this unit
[Ada] Secondary stack leak with access-to-subprogram
This patch modifies call resolution to recognize when the designated type of an access-to-subprogram requires secondary stack management, and establish the proper transient block. -- Source -- -- leak7.adb procedure Leak7 is Max_Iterations : constant := 10_000; function Func return String is begin return "Will this leak? Or will it dry?"; end Func; type Func_Ptr is access function return String; procedure Anonymous_Leak (Func : access function return String) is begin for Iteration in 1 .. Max_Iterations loop declare Val : constant String := Func.all; begin null; end; end loop; end Anonymous_Leak; procedure Named_Leak (Func : Func_Ptr) is begin for Iteration in 1 .. Max_Iterations loop declare Val : constant String := Func.all; begin null; end; end loop; end Named_Leak; begin Anonymous_Leak (Func'Access); Named_Leak (Func'Access); end Leak7; -- Compilation and output -- $ gnatmake -q leak7.adb $ valgrind ./leak7 >& leak7.txt $ grep -c "still reachable" leak7.txt 0 Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-31 Hristian Kirtchev gcc/ada/ * sem_res.adb (Resolve_Call): Establish a transient scope to manage the secondary stack when the designated type of an access-to-subprogram requires it.--- gcc/ada/sem_res.adb +++ gcc/ada/sem_res.adb @@ -6433,7 +6433,7 @@ package body Sem_Res is null; elsif Expander_Active -and then Ekind (Nam) = E_Function +and then Ekind_In (Nam, E_Function, E_Subprogram_Type) and then Requires_Transient_Scope (Etype (Nam)) then Establish_Transient_Scope (N, Manage_Sec_Stack => True);
[Ada] Remove inappropriate test from Is_By_Reference_Type
The result returned by the predicate may change depending on whether an error was posted on the type, which complicates further error reporting. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_aux.adb (Is_By_Reference_Type): Do not test Error_Posted.diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -846,10 +846,7 @@ package body Sem_Aux is Btype : constant Entity_Id := Base_Type (Ent); begin - if Error_Posted (Ent) or else Error_Posted (Btype) then - return False; - - elsif Is_Private_Type (Btype) then + if Is_Private_Type (Btype) then declare Utyp : constant Entity_Id := Underlying_Type (Btype); begin
[Ada] usage.adb: make -gnatw.c description clearer
The term "unrepped" can be hard to understand for users.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* usage.adb (Usage): Update -gnatw.c messages.diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -483,8 +483,10 @@ begin
Write_Line (".B turn off warnings for biased representation");
Write_Line ("c+ turn on warnings for constant conditional");
Write_Line ("C* turn off warnings for constant conditional");
- Write_Line (".c+ turn on warnings for unrepped components");
- Write_Line (".C* turn off warnings for unrepped components");
+ Write_Line (".c+ turn on warnings for components without " &
+ "representation clauses");
+ Write_Line (".C* turn off warnings for components without " &
+ "representation clauses");
Write_Line ("_c* turn on warnings for unknown " &
"Compile_Time_Warning");
Write_Line ("_C turn off warnings for unknown " &
[Ada] Move Build_And_Insert_Cuda_Initialization to Expand_CUDA_Package
This commit makes Build_And_Insert_Cuda_Initialization an internal procedure and creates a new Expand_CUDA_Package procedure which calls Build_And_Insert_Cuda_Initialization. This is a small, self-contained refactoring that does not impact any feature or fix any bug - it just makes future commits that do add new features smaller and easier to review. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch7.adb (Expand_N_Package_Body): Replace Build_And_Insert_Cuda_Initialization with Expand_CUDA_Package. * gnat_cuda.adb (Expand_CUDA_Package): New procedure. (Build_And_Insert_Cuda_Initialization): Make internal. * gnat_cuda.ads (Expand_CUDA_Package): New procedure. (Build_And_Insert_Cuda_Initialization): Remove from spec.diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5918,12 +5918,7 @@ package body Exp_Ch7 is Build_Static_Dispatch_Tables (N); end if; - -- If procedures marked with CUDA_Global have been defined within N, - -- we need to register them with the CUDA runtime at program startup. - -- This requires multiple declarations and function calls which need - -- to be appended to N's declarations. - - Build_And_Insert_CUDA_Initialization (N); + Expand_CUDA_Package (N); Build_Task_Activation_Call (N); diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb --- a/gcc/ada/gnat_cuda.adb +++ b/gcc/ada/gnat_cuda.adb @@ -66,6 +66,25 @@ package body GNAT_CUDA is -- least one procedure marked with aspect CUDA_Global. The values are -- Elists of the marked procedures. + procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); + -- Builds declarations necessary for CUDA initialization and inserts them + -- in N, the package body that contains CUDA_Global nodes. These + -- declarations are: + -- + --* A symbol to hold the pointer P to the CUDA fat binary. + -- + --* A type definition T for a wrapper that contains the pointer to the + -- CUDA fat binary. + -- + --* An object of the aforementioned type to hold the aforementioned + -- pointer. + -- + --* For each CUDA_Global procedure in the package, a declaration of a C + -- string containing the function's name. + -- + --* A procedure that takes care of calling CUDA functions that register + -- CUDA_Global procedures with the runtime. + function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; -- Returns an Elist of all procedures marked with pragma CUDA_Global that -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id @@ -94,6 +113,23 @@ package body GNAT_CUDA is Append_Elmt (Kernel, Kernels); end Add_CUDA_Kernel; + procedure Expand_CUDA_Package (N : Node_Id) is + begin + + -- If not compiling for the host, do not do anything. + + if not Debug_Flag_Underscore_C then + return; + end if; + + -- If procedures marked with CUDA_Global have been defined within N, + -- we need to register them with the CUDA runtime at program startup. + -- This requires multiple declarations and function calls which need + -- to be appended to N's declarations. + + Build_And_Insert_CUDA_Initialization (N); + end Expand_CUDA_Package; + -- -- Hash -- -- @@ -524,7 +560,7 @@ package body GNAT_CUDA is -- Start of processing for Build_And_Insert_CUDA_Initialization begin - if CUDA_Node_List = No_Elist or not Debug_Flag_Underscore_C then + if CUDA_Node_List = No_Elist then return; end if; diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads --- a/gcc/ada/gnat_cuda.ads +++ b/gcc/ada/gnat_cuda.ads @@ -82,26 +82,8 @@ package GNAT_CUDA is -- Kernel is a procedure entity marked with CUDA_Global, Pack_Id is the -- entity of its parent package body. - procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); - -- Builds declarations necessary for CUDA initialization and inserts them - -- in N, the package body that contains CUDA_Global nodes. These - -- declarations are: - -- - --* A symbol to hold the pointer to the CUDA fat binary - -- - --* A type definition for a wrapper that contains the pointer to the - -- CUDA fat binary - -- - --* An object of the aforementioned type to hold the aforementioned - -- pointer. - -- - --* For each CUDA_Global procedure in the package, a declaration of a C - -- string containing the function's name. - -- - --* A function that takes care of calling CUDA functions that register - -- CUDA_Global procedures with the runtime. - -- - --* A boolean that holds the result of the call to the aforementioned - -- function. + procedure Expand_CUDA_Package (N : Node_Id);
[Ada] Only assign type to op if compatible
Before this commit, the following program would make the compiler crash: procedure Main is ConstantString1 : aliased String := "Class1"; My_Access : access String := ConstantString1'Access; begin if "Class1" = My_Access then null; end if; end Main; This was because when an access type was given on the right side of an operator, GNAT assumed that an interpretation for the operator existed. This assumption resulted in no error being thrown and Gigi crashing when encountering the malformed tree. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Find_Non_Universal_Interpretations): Check if types are compatible before adding interpretation.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6626,7 +6626,7 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; - else + elsif Has_Compatible_Type (R, T1) then Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); end if; end Find_Non_Universal_Interpretations;
[Ada] Refactor scan_backend_switch to share logic across backends
This commit refactors scan_backend_switch to share logic across adabkend.adb and back_end.adb. A side effect of this refactor is that `-fdump-diagnostics-format` is now available with other backends. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * adabkend.adb (Scan_Back_End_Switches): Replace switch-scanning logic with call to Backend_Utils.Scan_Common_Back_End_Switches. * back_end.adb (Scan_Back_End_Switches): Replace switch-scanning logic with call to Backend_Utils.Scan_Common_Back_End_Switches. * backend_utils.adb: New file. * backend_utils.ads: New file. * gcc-interface/Make-lang.in: Add ada/backend_utils.o.diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -22,15 +22,16 @@ -- This is the version of the Back_End package for back ends written in Ada -with Atree;use Atree; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; with Debug; with Lib; -with Opt; use Opt; -with Output; use Output; -with Osint;use Osint; -with Osint.C; use Osint.C; -with Switch.C; use Switch.C; -with Types;use Types; +with Opt; use Opt; +with Output;use Output; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Switch.C; use Switch.C; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -182,48 +183,11 @@ package body Adabkend is return; - -- Special check, the back-end switch -fno-inline also sets the - -- front end flags to entirely inhibit all inlining. So we store it - -- and set the appropriate flags. - - elsif Switch_Chars (First .. Last) = "fno-inline" then -Lib.Store_Compilation_Switch (Switch_Chars); -Opt.Disable_FE_Inline := True; -return; - - -- Similar processing for -fpreserve-control-flow - - elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then -Lib.Store_Compilation_Switch (Switch_Chars); -Opt.Suppress_Control_Flow_Optimizations := True; -return; - - -- Recognize -gxxx switches - - elsif Switch_Chars (First) = 'g' then -Debugger_Level := 2; - -if First < Last then - case Switch_Chars (First + 1) is - when '0' => - Debugger_Level := 0; - when '1' => - Debugger_Level := 1; - when '2' => - Debugger_Level := 2; - when '3' => - Debugger_Level := 3; - when others => - null; - end case; -end if; - - elsif Switch_Chars (First .. Last) = "S" then -Generate_Asm := True; - -- Ignore all other back-end switches - elsif Is_Back_End_Switch (Switch_Chars) then + elsif Scan_Common_Back_End_Switch (Switch_Chars) +or else Is_Back_End_Switch (Switch_Chars) + then null; -- Give error for junk switch diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -25,23 +25,24 @@ -- This is the version of the Back_End package for GCC back ends -with Atree;use Atree; -with Debug;use Debug; -with Elists; use Elists; -with Errout; use Errout; -with Lib; use Lib; -with Osint;use Osint; -with Opt; use Opt; -with Osint.C; use Osint.C; -with Namet;use Namet; -with Nlists; use Nlists; -with Stand;use Stand; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Switch; use Switch; -with Switch.C; use Switch.C; -with System; use System; -with Types;use Types; +with Atree; use Atree; +with Backend_Utils; use Backend_Utils; +with Debug; use Debug; +with Elists;use Elists; +with Errout;use Errout; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint.C; use Osint.C; +with Namet; use Namet; +with Nlists;use Nlists; +with Stand; use Stand; +with Sinput;use Sinput; +with Stringt; use Stringt; +with Switch;use Switch; +with Switch.C; use Switch.C; +with System;use System; +with Types; use Types; with System.OS_Lib; use System.OS_Lib; @@ -266,52 +267,20 @@ package body Back_End is -- specific switches that the Ada front-end knows about. else -Store_Compilation_Switch (Switch_Chars); - --- For gcc back ends, -fno-inline disables Inline pragmas only, --- not Inline_Always to remain consistent with the always_inline --- attribute behavior. - -if Switch_Chars (First .. Last) = "fno-inline" then - Opt.Disable_FE_Inline := True; - -
[Ada] Spurious accessibility error on allocator in generic instance
This patch fixes an error in the compiler whereby an allocator for a limited type within a generic instance may cause spurious compile-time warnings and run-time errors. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch4.adb (Expand_N_Type_Conversion): Add guard to protect against calculating accessibility levels against internal compiler-generated types.diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12361,10 +12361,16 @@ package body Exp_Ch4 is -- an instantiation, otherwise the conversion will already have been -- rejected as illegal. - -- Note: warnings are issued by the analyzer for the instance cases + -- Note: warnings are issued by the analyzer for the instance cases, + -- and, since we are late in expansion, a check is performed to + -- verify that neither the target type nor the operand type are + -- internally generated - as this can lead to spurious errors when, + -- for example, the operand type is a result of BIP expansion. elsif In_Instance_Body and then Statically_Deeper_Relation_Applies (Target_Type) + and then not Is_Internal (Target_Type) + and then not Is_Internal (Operand_Type) and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then
[Ada] Fix assertion in GNATprove_Mode
Avoid calling List_Rep_Info in Generate_SCIL and GNATprove_Mode, because
the representation info is not there. Otherwise, we fail an assertion.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* gnat1drv.adb (Gnat1drv): Avoid calling List_Rep_Info in
Generate_SCIL and GNATprove_Mode.
* repinfo.adb (List_Common_Type_Info): Fix comment.diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -1616,7 +1616,14 @@ begin
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
- Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian);
+
+ -- Back annotation of representation info is not done in CodePeer and
+ -- SPARK modes.
+
+ if not (Generate_SCIL or GNATprove_Mode) then
+ Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian);
+ end if;
+
Inline.List_Inlining_Info;
-- Only write the library if the backend did not generate any error
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -422,7 +422,8 @@ package body Repinfo is
Write_Line (";");
end if;
- -- Alignment is not always set for task and protected types
+ -- Alignment is not always set for task, protected, and class-wide
+ -- types.
else
pragma Assert
[Ada] Don't examine all discriminants when looking for the first one
A minor performance improvement; semantics is unaffected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch3.adb (Build_Discriminant_Constraints): Exit once a first discriminant is found and the Discrim_Present flag is set.diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10392,6 +10392,7 @@ package body Sem_Ch3 is (Discr_Expr (J), Check_Concurrent => True) then Discrim_Present := True; +exit; end if; end loop;
[Ada] Work around CodePeer bug by declaring variable
This commit works around a CodePeer bug where CodePeer thinks Get_32_Bit_Val returns something uninitialized. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * atree.adb (Get_32_Bit_Field): Declare result before returning.diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -513,8 +513,13 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_32_Bit, Field_Type); + + Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset)); + -- Note: declaring Result here instead of directly returning + -- Cast (...) helps CodePeer understand that there are no issues + -- around uninitialized variables. begin - return Cast (Get_32_Bit_Val (N, Offset)); + return Result; end Get_32_Bit_Field; function Get_32_Bit_Field_With_Default
[Ada] Small cleanup in System.Dwarf_Line
The unit has got "with" and "use" clauses both for Ada.Exceptions.Traceback and System.Traceback_Entries, but the former is essentially a forwarder for the latter so can be eliminated. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/s-dwalin.ads: Remove clause for Ada.Exceptions.Traceback, add clause for System.Traceback_Entries and alphabetize. (AET): Delete. (STE): New package renaming. (Symbolic_Traceback): Adjust. * libgnat/s-dwalin.adb: Remove clauses for Ada.Exceptions.Traceback and System.Traceback_Entries. (Symbolic_Traceback): Adjust.diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -31,7 +31,6 @@ with Ada.Characters.Handling; with Ada.Containers.Generic_Array_Sort; -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Ada.Unchecked_Deallocation; with Interfaces; use Interfaces; @@ -42,7 +41,6 @@ with System.Bounded_Strings; use System.Bounded_Strings; with System.IO;use System.IO; with System.Mmap; use System.Mmap; with System.Object_Reader; use System.Object_Reader; -with System.Traceback_Entries; use System.Traceback_Entries; with System.Storage_Elements; use System.Storage_Elements; package body System.Dwarf_Lines is @@ -1864,7 +1862,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Traceback (Cin :Dwarf_Context; - Traceback:AET.Tracebacks_Array; + Traceback:STE.Tracebacks_Array; Suppress_Hex :Boolean; Symbol_Found :out Boolean; Res : in out System.Bounded_Strings.Bounded_String) @@ -1893,7 +1891,7 @@ package body System.Dwarf_Lines is -- If the buffer is full, no need to do any useless work exit when Is_Full (Res); - Addr_In_Traceback := PC_For (Traceback (J)); + Addr_In_Traceback := STE.PC_For (Traceback (J)); Offset_To_Lookup := Addr_In_Traceback - C.Load_Address; diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -35,15 +35,14 @@ -- -- Files must be compiled with at least minimal debugging information (-g1). -with Ada.Exceptions.Traceback; - +with System.Bounded_Strings; with System.Object_Reader; with System.Storage_Elements; -with System.Bounded_Strings; +with System.Traceback_Entries; package System.Dwarf_Lines is - package AET renames Ada.Exceptions.Traceback; + package STE renames System.Traceback_Entries; package SOR renames System.Object_Reader; type Dwarf_Context (In_Exception : Boolean := False) is private; @@ -83,7 +82,7 @@ package System.Dwarf_Lines is procedure Symbolic_Traceback (Cin :Dwarf_Context; - Traceback:AET.Tracebacks_Array; + Traceback:STE.Tracebacks_Array; Suppress_Hex :Boolean; Symbol_Found :out Boolean; Res : in out System.Bounded_Strings.Bounded_String);
[Ada] Implementation of Preelaborable_Initialization attribute for AI12-0409
This set of changes implements the Preelaborable_Initialization attribute, corresponding to the existing aspect/pragma, as defined by AI12-0409 (RM2022 10.2.1(11.6/5-11.8/5). This includes semantic checking of restrictions on the prefix, and support for the aspect expression being given by an expression with one or more P_I attributes applied to formal private or derived types, when the type with the aspect is specified on types within a generic package declaration (the value of the aspect in instantiations can be different depending on the actual types), as well as applying preelaborable-initialization restrictions on full types when the partial type has such aspects. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_attr.adb (Expand_N_Attribute_Reference): Fold Preelaborable_Initialization attribute in cases where it hasn't been folded by the analyzer. * exp_disp.adb (Original_View_In_Visible_Part): This function is removed and moved to sem_util.adb. * sem_attr.adb (Attribute_22): Add Attribute_Preelaborable_Initialization as an Ada 2022 attribute. (Analyze_Attribute, Attribute_Preelaborable_Initialization): Check that the prefix of the attribute is either a formal private or derived type, or a composite type declared within the visible part of a package or generic package. (Eval_Attribute): Perform folding of Preelaborable_Initialization attribute based on Has_Preelaborable_Initialization applied to the prefix type. * sem_ch3.adb (Resolve_Aspects): Add specialized code for Preelaborable_Initialization used at the end of a package visible part for setting Known_To_Have_Preelab_Init on types that are specified with True or that have a conjunction of one or more P_I attributes applied to formal types. * sem_ch7.adb (Analyze_Package_Specification): On call to Has_Preelaborable_Initialization, pass True for new formal Formal_Types_Have_Preelab_Init, so that error checking treats subcomponents that are declared within types in generics as having preelaborable initialization when the subcomponents are of formal types. * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Add test for P_I to prevent calling Make_Pragma_From_Boolean_Aspect, since this aspect is handled specially and the Known_To_Have_Preelab_Init flag will get set on types that have the aspect by other means. (Analyze_Aspect_Specifications.Analyze_One_Aspect): Add test for Aspect_Preelaborable_Initialization for allowing the aspect to be specified on formal type declarations. (Is_Operational_Item): Treat Attribute_Put_Image as an operational attribute. The need for this was encountered while working on these changes. * sem_util.ads (Has_Preelaborable_Initialization): Add Formal_Types_Have_Preelab_Init as a new formal parameter that defaults to False. (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New function. (Original_View_In_Visible_Part): Moved here from exp_disp.adb, so it can be called by Analyze_Attribute. * sem_util.adb (Has_Preelaborable_Initialization): Return True for formal private and derived types when new formal Formal_Types_Have_Preelab_Init is True, and pass along the Formal_Types_Have_Preelab_Init flag in the array component case. (Check_Components): Pass along Formal_Types_Have_Preelab_Init flag on call to Has_Preelaborable_Initialization. (Is_Conjunction_Of_Formal_Preelab_Init_Attributes): New function that returns True when passed an expression that includes one or more attributes for Preelaborable_Initialization applied to prefixes that denote formal types. (Is_Formal_Preelab_Init_Attribute): New utility function nested within Is_Conjunction_Of_Formal_Preelab_Init_Attributes that determines whether a node is a P_I attribute applied to a generic formal type. (Original_View_In_Visible_Part): Moved here from exp_util.adb, so it can be called by Analyze_Attribute. * snames.ads-tmpl: Add note near the start of spec giving details about what needs to be done when adding a name that corresponds to both an attribute and a pragma. Delete existing occurrence of Name_Preelaborable_Initialization, and add a note comment in the list of Name_* constants at that place, indicating that it's included in type Pragma_Id, etc., echoing other such comments for names that are both an attribute and a pragma. Insert Name_Preelaborable_Initialization in the alphabetized set of Name_* constants corresponding to attributes (between First_Attribute_Name and Last_Attribute_Name).
[Ada] Refine types of local constants that store Etype results
Calls to Etype return entities, even though the signature of the Etype routine says it returns nodes. Fixed automatically with: $ sed -i 's/ Node_Id := Etype/ Entity_Id := Etype/' *.adb Found while reviewing changes in GNATprove related to aliasing checks. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_aggr.adb, exp_ch4.adb, exp_ch5.adb, sprint.adb: Refine types of local constants.diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4003,7 +4003,7 @@ package body Exp_Aggr is and then Present (First_Index (Etype (Expr_Q))) then declare - Expr_Q_Type : constant Node_Id := Etype (Expr_Q); + Expr_Q_Type : constant Entity_Id := Etype (Expr_Q); begin Append_List_To (L, Build_Array_Aggr_Code diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7763,8 +7763,8 @@ package body Exp_Ch4 is if Is_Unchecked_Union (Op_Type) then declare - Lhs_Type : constant Node_Id := Etype (L_Exp); - Rhs_Type : constant Node_Id := Etype (R_Exp); + Lhs_Type : constant Entity_Id := Etype (L_Exp); + Rhs_Type : constant Entity_Id := Etype (R_Exp); Lhs_Discr_Vals : Elist_Id; -- List of inferred discriminant values for left operand. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -742,8 +742,8 @@ package body Exp_Ch5 is -- in the front end. declare - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); @@ -1382,8 +1382,8 @@ package body Exp_Ch5 is Loc : constant Source_Ptr := Sloc (N); - L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); - R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); + L_Index_Typ : constant Entity_Id := Etype (First_Index (L_Type)); + R_Index_Typ : constant Entity_Id := Etype (First_Index (R_Type)); Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4222,7 +4222,7 @@ package body Sprint is -- Itype to be printed declare -B : constant Node_Id := Etype (Typ); +B : constant Entity_Id := Etype (Typ); P : constant Node_Id := Parent (Typ); S : constant Saved_Output_Buffer := Save_Output_Buffer; -- Save current output buffer
[Ada] Spurious link error with child unit and different Assertion modes.
This patch fixes a spurious link error on a compilation that involves a child unit that must be compiled with assertions enabled, and a parent that is compiled without. The error occurs when the parent includes instantiations that involve constructs such as predicates or pre/ postconditions, and object declarations for discriminated types with complex discriminant constraints. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_util.ads (Force_Evaluation): Add formal parameter Discr_Number, to indicate discriminant expression for which an external name must be created. (Remove_Side_Effects): Ditto. * exp_util.adb (Force_Evaluation): Call Remove_Side_Effects with added parameter. (Remove_Side_Effects, Build_Temporary): If Discr_Number is positive, create an external name with suffix DISCR and the given discriminant number, analogous to what is done for temporaries for array type bounds. * sem_ch3.adb (Process_Discriminant_Expressions): If the constraint is for an object or component declaration and the corresponding entity may be visible in another unit, invoke Force_Evaluation with the new parameter.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6589,6 +6589,7 @@ package body Exp_Util is Related_Id: Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Mode : Force_Evaluation_Mode := Relaxed) is begin @@ -6600,6 +6601,7 @@ package body Exp_Util is Related_Id => Related_Id, Is_Low_Bound => Is_Low_Bound, Is_High_Bound => Is_High_Bound, + Discr_Number => Discr_Number, Check_Side_Effects => Is_Static_Expression (Exp) or else Mode = Relaxed); @@ -11623,6 +11625,7 @@ package body Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Check_Side_Effects : Boolean := True) is function Build_Temporary @@ -11653,13 +11656,28 @@ package body Exp_Util is Temp_Nam : Name_Id; begin - -- The context requires an external symbol + -- The context requires an external symbol : expression is + -- the bound of an array, or a discriminant value. We create + -- a unique string using the related entity and an appropriate + -- suffix, rather than a numeric serial number (used for internal + -- entities) that may vary depending on compilation options, in + -- particular on the Assertions_Enabled mode. This avoids spurious + -- link errors. if Present (Related_Id) then if Is_Low_Bound then Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST"); -else pragma Assert (Is_High_Bound); + +elsif Is_High_Bound then Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST"); + +else + pragma Assert (Discr_Number > 0); + -- Use fully qualified name to avoid ambiguities. + + Temp_Nam := + New_External_Name + (Get_Qualified_Name (Related_Id), "_DISCR", Discr_Number); end if; Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -668,6 +668,7 @@ package Exp_Util is Related_Id: Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound : Boolean := False; + Discr_Number : Int := 0; Mode : Force_Evaluation_Mode := Relaxed); -- Force the evaluation of the expression right away. Similar behavior -- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to @@ -688,6 +689,12 @@ package Exp_Util is -- of the Is_xxx_Bound flags must be set. For use of these parameters see -- the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. + -- Discr_Number is positive when the expression is a discriminant value + -- in an object or component declaration. In that case Discr_Number is + -- the position of the corresponding discriminant in the corresponding + -- type declaration, and the name for the evaluated expression is built + -- out of the Related_Id and the Discr_Number. + function Fully_Qualified_Name_String (E : Entity_Id; Append_NUL : Boolean := True) return String_Id; @@ -1004,6 +1011,7 @@ package Exp_Util is Related_Id : Entity_Id := Empty; Is_Low_Bound : Boolean := False; Is_High_Bound :
[Ada] Fix condition in op interpretation resolution
A previous patch fixed crashes on comparisons of string literals with access to strings by making sure that resolution of operations was only performed when operand types are actually compatible. However, the check was incomplete. Indeed, using only Has_Compatible_Type does not cover the case where the right operand's type covers the left operand's, which caused programs such as the following to fail: procedure tmp is type Root is tagged null record; type Child is new Root with null record; type Grandchild is new Child with null record; GC : access Grandchild; CC : access Child'Class; begin if GC = CC then null; end if; end tmp; The fix is trivial: when the type of the right operand covers the type of the left one, allow resolution of the operation. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Finc_Non_Universal_Interpretations): Fix check.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6626,7 +6626,7 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; - elsif Has_Compatible_Type (R, T1) then + elsif Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); end if; end Find_Non_Universal_Interpretations;
[Ada] Fix repeated generation of dispatch tables in CodePeer mode
Routine Make_DT that generates dispatch tables for tagged types might be called twice: when the tagged type is frozen (if it requires freezing) and once the enclosing package is fully analyzed. The Has_Dispatch_Table flag on a type prevents dispatch tables being generated twice. However, this flag was only set in ordinary compilation mode, not in the CodePeer mode. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_disp.adb (Make_DT): Move call to Set_Has_Dispatch_Table, so it is executed regardless of the Generate_SCIL mode.diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6610,7 +6610,6 @@ package body Exp_Disp is Append_Elmt (DT, DT_Decl); Analyze_List (Result, Suppress => All_Checks); - Set_Has_Dispatch_Table (Typ); -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. @@ -6643,6 +6642,8 @@ package body Exp_Disp is <> + Set_Has_Dispatch_Table (Typ); + -- Register the tagged type in the call graph nodes table Register_CG_Node (Typ);
[Ada] SPARK proof of the Ada.Strings.Fixed library
Introduced pragmas to prove with SPARK the behaviours of most of the
functions and procedures from Ada.Strings.Fixed. Procedure Move and all
procedures that rely on it (Insert, Delete, Overwrite, Replace_Slice)
have incomplete contracts and can have runtime errors. Function Count is
given without a postcondition because it would be hard to express, but
absence of runtime errors is ensured. The private package
Ada.Strings.Search has also been made public, to allow the use of Match
in the contracts of Ada.Strings.Fixed.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* libgnat/a-strfix.adb ("*"): Added loop invariants and lemmas
for proof.
(Delete): Added assertions for proof, and conditions to avoid
overflow.
(Head): Added loop invariant.
(Insert): Same as Delete.
(Move): Declared with SPARK_Mode Off.
(Overwrite): Added assertions for proof, and conditions to avoid
overflow.
(Replace_Slice): Added assertions for proof, and conditions to
avoid overflow.
(Tail): Added loop invariant and avoided overflows.
(Translate): Added loop invariants.
(Trim): Ensured empty strings returned start at 1.
* libgnat/a-strfix.ads (Index): Rewrote contract cases for
easier proof.
(Index_Non_Blank): Separated the null string case.
(Count): Specified Mapping shouldn't be null.
(Find_Token): Specified Source'First should be Positive when no
From is given.
(Translate): Specified Mapping shouldn't be null.
("*"): Rewrote postcondition for easier proof.
* libgnat/a-strsea.adb (Belongs): Added postcondition.
(Count): Rewrote loops and added loop invariants to avoid
overflows.
(Find_Token): Added loop invariants.
(Index): Rewrote loops to avoid overflows and added loop
invariants for proof.
(Index_Non_Blank): Added loop invariants.
(Is_Identity): New function isolated without SPARK_Mode.
* libgnat/a-strsea.ads: Fix starting comment as package is no
longer private.
(Match): Declared ghost expression function Match.
(Is_Identity): Described identity in the postcondition.
(Index, Index_Non_Blank, Count, Find_Token): Added contract from
a-strfix.ads.
patch.diff.gz
Description: application/gzip
[Ada] Adjust latest change for ELF platforms
Shared libraries effectively have a "static" load address of zero in ELF. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/s-objrea.adb (Get_Load_Address): Return 0 for ELF.diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb --- a/gcc/ada/libgnat/s-objrea.adb +++ b/gcc/ada/libgnat/s-objrea.adb @@ -1656,12 +1656,11 @@ package body System.Object_Reader is function Get_Load_Address (Obj : Object_File) return uint64 is begin - if Obj.Format in Any_PECOFF then - return Obj.ImageBase; - - else - raise Format_Error with "Get_Load_Address not implemented"; - end if; + case Obj.Format is + when ELF=> return 0; + when Any_PECOFF => return Obj.ImageBase; + when XCOFF32=> raise Format_Error; + end case; end Get_Load_Address; -
[Ada] Add support for PE-COFF PIE to System.Dwarf_Line
This makes it possible for System.Dwarf_Line to handle Position-Independent Executables on Windows systems by translating the run-time addresses it is provided with into addresses in the executable. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * adaint.c (__gnat_get_executable_load_address): Add Win32 support. * libgnat/s-objrea.ads (Get_Xcode_Bounds): Fix typo in comment. (Object_File): Minor reformatting. (ELF_Object_File): Uncomment predicate. (PECOFF_Object_File): Likewise. (XCOFF32_Object_File): Likewise. * libgnat/s-objrea.adb: Minor reformatting throughout. (Get_Load_Address): Implement for PE-COFF. * libgnat/s-dwalin.ads: Remove clause for System.Storage_Elements and use consistent wording in comments. (Dwarf_Context): Set type of Low, High and Load_Address to Address. * libgnat/s-dwalin.adb (Get_Load_Displacement): New function. (Is_Inside): Call Get_Load_Displacement. (Low_Address): Likewise. (Open): Adjust to type change. (Aranges_Lookup): Change type of Addr to Address. (Read_Aranges_Entry): Likewise for Start and adjust. (Enable_Cach): Adjust to type change. (Symbolic_Address): Change type of Addr to Address. (Symbolic_Traceback): Call Get_Load_Displacement.diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -3542,6 +3542,9 @@ __gnat_get_executable_load_address (void) return (const void *)map->l_addr; +#elif defined (_WIN32) + return GetModuleHandle (NULL); + #else return NULL; #endif diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -47,6 +47,10 @@ package body System.Dwarf_Lines is SSU : constant := System.Storage_Unit; + function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset; + -- Return the displacement between the load address present in the binary + -- and the run-time address at which it is loaded (i.e. non-zero for PIE). + function String_Length (Str : Str_Access) return Natural; -- Return the length of the C string Str @@ -74,7 +78,7 @@ package body System.Dwarf_Lines is procedure Read_Aranges_Entry (C : in out Dwarf_Context; - Start :out Storage_Offset; + Start :out Address; Len :out Storage_Count); -- Read a single .debug_aranges pair @@ -86,7 +90,7 @@ package body System.Dwarf_Lines is procedure Aranges_Lookup (C : in out Dwarf_Context; - Addr:Storage_Offset; + Addr:Address; Info_Offset :out Offset; Success :out Boolean); -- Search for Addr in .debug_aranges and return offset Info_Offset in @@ -151,7 +155,7 @@ package body System.Dwarf_Lines is procedure Symbolic_Address (C : in out Dwarf_Context; - Addr:Storage_Offset; + Addr:Address; Dir_Name:out Str_Access; File_Name :out Str_Access; Subprg_Name :out String_Ptr_Len; @@ -368,6 +372,19 @@ package body System.Dwarf_Lines is end loop; end For_Each_Row; + --- + -- Get_Load_Displacement -- + --- + + function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset is + begin + if C.Load_Address /= Null_Address then + return C.Load_Address - Address (Get_Load_Address (C.Obj.all)); + else + return 0; + end if; + end Get_Load_Displacement; + - -- Initialize_Pass -- - @@ -403,18 +420,19 @@ package body System.Dwarf_Lines is --- function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is + Disp : constant Storage_Offset := Get_Load_Displacement (C); + begin - return (Addr >= C.Low + C.Load_Address -and then Addr <= C.High + C.Load_Address); + return Addr >= C.Low + Disp and then Addr <= C.High + Disp; end Is_Inside; - -- Low_Address -- - - function Low_Address (C : Dwarf_Context) return System.Address is + function Low_Address (C : Dwarf_Context) return Address is begin - return C.Load_Address + C.Low; + return C.Low + Get_Load_Displacement (C); end Low_Address; -- @@ -448,12 +466,12 @@ package body System.Dwarf_Lines is Success := True; - -- Get memory bounds for executable code. Note that such code + -- Get address bounds for executable code. Note that such code -- might come from multiple sections. Get_Xcode_Bounds (C.Obj.all, Lo, Hi); - C.Low := Storage_Offset (Lo); - C.High := Storage_Offset (Hi); + C.Low := Address (Lo); + C.High := Addre
[Ada] Cleanups related to building of dispatch tables
Code cleanup only; semantics is unaffected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch7.adb (Expand_N_Package_Declaration): Fix wording in comment. * exp_disp.adb (Mark_DT): Remove unnecessary initialization of I_Depth.diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6067,7 +6067,7 @@ package body Exp_Ch7 is Pop_Scope; end if; - -- Build dispatch tables of library level tagged types + -- Build dispatch tables of library-level tagged types if Tagged_Type_Expansion and then (Is_Compilation_Unit (Id) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4712,7 +4712,7 @@ package body Exp_Disp is Exname : Entity_Id; HT_Link: Entity_Id; ITable : Node_Id; - I_Depth: Nat := 0; + I_Depth: Nat; Iface_Table_Node : Node_Id; Name_ITable: Name_Id; Nb_Prim: Nat := 0;
[Ada] Use OS_Time for interface to TZ functions.
A recent regression caused by the parameterization of time_t was due to
the unusual declaration used for time_t in the interface to TZ functions
in sysdep.c. The root cause was the Long_Integer size of 32 bits used on
x86_64-windows. The incident was temporarily fixed by reverting the
declaration to its former self.
This however will break vxworks SR0660 use of 64-bit time_t on 32-bit
targets. The proper fix below is to use OS_Time for the interface to
ensure compatibility independent of Long_Integer size.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* libgnat/a-calend.adb: Remove time_t, replace with OS_Time.
* libgnat/s-os_lib.ads: Fix comments regarding time_t conversion
functions to reflect the use of To_Ada in in Ada.Calendar
package body.
* sysdep.c (__gnat_localtime_tzoff): Use OS_Time instead of
time_t.diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb
--- a/gcc/ada/libgnat/a-calend.adb
+++ b/gcc/ada/libgnat/a-calend.adb
@@ -35,6 +35,8 @@ with Interfaces.C;
with System.OS_Primitives;
+with System.OS_Lib;
+
package body Ada.Calendar with
SPARK_Mode => Off
is
@@ -685,13 +687,10 @@ is
type int_Pointer is access all Interfaces.C.int;
type long_Pointer is access all Interfaces.C.long;
- type time_t is
-range -(2 ** (Standard'Address_Size - Integer'(1))) ..
- +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
- type time_t_Pointer is access all time_t;
+ type OS_Time_Pointer is access all System.OS_Lib.OS_Time;
procedure localtime_tzoff
-(timer : time_t_Pointer;
+(timer : OS_Time_Pointer;
is_historic : int_Pointer;
off : long_Pointer);
pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
@@ -708,7 +707,7 @@ is
Date_N : Time_Rep;
Flag : aliased Interfaces.C.int;
Offset : aliased Interfaces.C.long;
- Secs_T : aliased time_t;
+ Secs_T : aliased System.OS_Lib.OS_Time;
-- Start of processing for UTC_Time_Offset
@@ -745,7 +744,7 @@ is
-- Convert the date into seconds
- Secs_T := time_t (Date_N / Nano);
+ Secs_T := System.OS_Lib.To_Ada (Long_Long_Integer (Date_N / Nano));
-- Determine whether to treat the input date as historical or not. A
-- value of "0" signifies that the date is NOT historic.
diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads
--- a/gcc/ada/libgnat/s-os_lib.ads
+++ b/gcc/ada/libgnat/s-os_lib.ads
@@ -169,16 +169,15 @@ package System.OS_Lib is
--
-- Note: Do not use time_t in the compiler and host-based tools; instead
- -- use OS_Time. These 3 declarations are intended for use only by consumers
- -- of the GNAT.OS_Lib renaming of this package.
+ -- use OS_Time.
subtype time_t is Long_Long_Integer;
- -- C time_t can be either long or long long, but this is a subtype not used
- -- in the compiler or tools, but only for user applications, so we choose
- -- the Ada equivalent of the latter because eventually that will be the
+ -- C time_t can be either long or long long, so we choose the Ada
+ -- equivalent of the latter because eventually that will be the
-- type used out of necessity. This may affect some user code on 32-bit
-- targets that have not yet migrated to the Posix 2008 standard,
- -- particularly pre version 5 32-bit Linux.
+ -- particularly pre version 5 32-bit Linux. Do not change this
+ -- declaration without coordinating it with conversions in Ada.Calendar.
function To_C (Time : OS_Time) return time_t;
-- Convert OS_Time to C time_t type
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -643,11 +643,11 @@ long __gnat_invalid_tzoff = 259273;
/* Reentrant localtime for Windows. */
extern void
-__gnat_localtime_tzoff (const time_t *, const int *, long *);
+__gnat_localtime_tzoff (const OS_Time *, const int *, long *);
static const unsigned long long w32_epoch_offset = 11644473600ULL;
void
-__gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off)
+__gnat_localtime_tzoff (const OS_Time *timer, const int *is_historic, long *off)
{
TIME_ZONE_INFORMATION tzi;
@@ -737,10 +737,10 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off)
the Lynx convention when building against the legacy API. */
extern void
-__gnat_localtime_tzoff (const time_t *, const int *, long *);
+__gnat_localtime_tzoff (const OS_Time *, const int *, long *);
void
-__gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off)
+__gnat_localtime_tzoff (const OS_Time *timer, const int *is_historic, long *off)
{
*off = 0;
}
@@ -756,21 +756,22 @@ extern void (*Lock_Task) (void);
extern void (*Unlock_Task) (void);
extern void
-__gnat_localtime_tzoff (
[Ada] Accept volatile expressions as non-scalar actual parameters
This change removes an old, incomplete and duplicated code that
implemented the very first wording of a SPARK RM rule related to
volatile expressions acting as actual parameters.
Current the rule says: "[a name denoting] an effectively volatile object
for reading [can be] an actual parameter in a call for which the
corresponding formal parameter is of a non-scalar effectively volatile
type for reading".
This wording is implemented in Is_OK_Volatile_Context and enforced when
this routine is called by Resolve_Actuals via
Flag_Effectively_Volatile_Objects with Check_Actuals parameter being
True.
In particular, the removed code was incorrectly only looking at
procedure calls and their parameters of mode IN; the rule applies to
also to function and entry calls and their parameters of modes IN OUT
and OUT too.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_res.adb (Resolve_Actual): Removediff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3454,7 +3454,6 @@ package body Sem_Res is
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
Loc: constant Source_Ptr := Sloc (N);
A : Node_Id;
- A_Id : Entity_Id;
A_Typ : Entity_Id := Empty; -- init to avoid warning
F : Entity_Id;
F_Typ : Entity_Id;
@@ -4969,31 +4968,6 @@ package body Sem_Res is
-- must be resolved first.
Flag_Effectively_Volatile_Objects (A);
-
- -- An effectively volatile variable cannot act as an actual
- -- parameter in a procedure call when the variable has enabled
- -- property Effective_Reads and the corresponding formal is of
- -- mode IN (SPARK RM 7.1.3(10)).
-
- if Ekind (Nam) = E_Procedure
- and then Ekind (F) = E_In_Parameter
- and then Is_Entity_Name (A)
- then
- A_Id := Entity (A);
-
- if Ekind (A_Id) = E_Variable
-and then Is_Effectively_Volatile_For_Reading (Etype (A_Id))
-and then Effective_Reads_Enabled (A_Id)
- then
- Error_Msg_NE
- ("effectively volatile variable & cannot appear as "
-& "actual in procedure call", A, A_Id);
-
- Error_Msg_Name_1 := Name_Effective_Reads;
- Error_Msg_N ("\\variable has enabled property %", A);
- Error_Msg_N ("\\corresponding formal has mode IN", A);
- end if;
- end if;
end if;
-- A formal parameter of a specific tagged type whose related
[Ada] Accept volatile properties on constant objects
Aspects Volatile and its related properties, i.e. Async_Readers,
Async_Writers, Effective_Reads, Effective_Writes and No_Caching, are now
allowed on stand-alone constant objects in SPARK.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* contracts.adb (Add_Contract_Item): Accept volatile-related
properties on constants.
(Analyze_Object_Contract): Check external properties on
constants; accept volatile constants.
(Check_Type_Or_Object_External_Properties): Replace "variable"
with "object" in error messages; replace Decl_Kind with a local
constant.
* sem_prag.adb (Analyze_Pragma): Accept volatile-related
properties on constants.diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -144,7 +144,13 @@ package body Contracts is
--Part_Of
if Ekind (Id) = E_Constant then
- if Prag_Nam = Name_Part_Of then
+ if Prag_Nam in Name_Async_Readers
+ | Name_Async_Writers
+ | Name_Effective_Reads
+ | Name_Effective_Writes
+ | Name_No_Caching
+ | Name_Part_Of
+ then
Add_Classification;
-- The pragma is not a proper contract item
@@ -778,25 +784,9 @@ package body Contracts is
procedure Check_Type_Or_Object_External_Properties
(Type_Or_Obj_Id : Entity_Id)
is
- function Decl_Kind (Is_Type : Boolean;
- Object_Kind : String) return String;
- -- Returns "type" or Object_Kind, depending on Is_Type
-
- ---
- -- Decl_Kind --
- ---
-
- function Decl_Kind (Is_Type : Boolean;
- Object_Kind : String) return String is
- begin
- if Is_Type then
-return "type";
- else
-return Object_Kind;
- end if;
- end Decl_Kind;
-
Is_Type_Id : constant Boolean := Is_Type (Type_Or_Obj_Id);
+ Decl_Kind : constant String :=
+(if Is_Type_Id then "type" else "object");
-- Local variables
@@ -923,8 +913,7 @@ package body Contracts is
if not Is_Library_Level_Entity (Type_Or_Obj_Id) then
Error_Msg_N
("effectively volatile "
-& Decl_Kind (Is_Type => Is_Type_Id,
- Object_Kind => "variable")
+& Decl_Kind
& " & must be declared at library level "
& "(SPARK RM 7.1.3(3))", Type_Or_Obj_Id);
@@ -935,10 +924,7 @@ package body Contracts is
and then not Is_Protected_Type (Obj_Typ)
then
Error_Msg_N
-("discriminated "
- & Decl_Kind (Is_Type => Is_Type_Id,
-Object_Kind => "object")
- & " & cannot be volatile",
+("discriminated " & Decl_Kind & " & cannot be volatile",
Type_Or_Obj_Id);
end if;
@@ -1019,7 +1005,7 @@ package body Contracts is
Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save the SPARK_Mode-related data to restore on exit
- NC_Val : Boolean := False;
+ NC_Val : Boolean;
Items: Node_Id;
Prag : Node_Id;
Ref_Elmt : Elmt_Id;
@@ -1056,6 +1042,19 @@ package body Contracts is
Set_SPARK_Mode (Obj_Id);
end if;
+ -- Checks related to external properties, same for constants and
+ -- variables.
+
+ Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id => Obj_Id);
+
+ -- Analyze the non-external volatility property No_Caching
+
+ Prag := Get_Pragma (Obj_Id, Pragma_No_Caching);
+
+ if Present (Prag) then
+ Analyze_External_Property_In_Decl_Part (Prag, NC_Val);
+ end if;
+
-- Constant-related checks
if Ekind (Obj_Id) = E_Constant then
@@ -1071,35 +1070,10 @@ package body Contracts is
Check_Missing_Part_Of (Obj_Id);
end if;
- -- A constant cannot be effectively volatile (SPARK RM 7.1.3(4)).
- -- This check is relevant only when SPARK_Mode is on, as it is not
- -- a standard Ada legality rule. Internally-generated constants that
- -- map generic formals to actuals in instantiations are allowed to
- -- be volatile.
-
- if SPARK_Mode = On
- and then Comes_From_Source (Obj_Id)
- and then Is_Effectively_Volatile (Obj_Id)
- and then No (Corresponding_Generic_Association (Parent (Obj_Id)))
- then
-Error_Msg_N ("constant cannot be volatile", Obj_Id);
- end if;
-
-- Variable-related checks
else pragma Assert (Ekind (Obj_Id) = E_Variable);
- Check_Type_Or_Object_External_Properties
- (Ty
[Ada] Clean up Uint fields, remove unused routines
Remove unused routines. Remove 2-parameter versions of Init_Alignment and friends. Replace calls with direct calls to Set_Alignment and friends. These routines aren't really doing anything worth an extra abstraction. Change remaining Init_ routines to Reinit_, because these are not usually being used to initialize. Reinit_Alignment correctly calls Reinit_Field_To_Zero. The other two (Reinit_Esize and Reinit_RM_Size) are still setting the field to Uint_0; this will be changed to Reinit_Field_To_Zero later. Add Copy_Esize and Copy_RM_Size, not yet implemented. These will be implemented when Reinit_Esize and Reinit_RM_Size are corrected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * einfo-utils.ads, einfo-utils.adb, fe.h, einfo.ads, gen_il-fields.ads: Remove unused and no-longer-used routines. Move related routines together. Rewrite incorrect documentation, and documentation that will be incorrect when e.g. Esize-related routines are fixed. Remove unused field Normalized_Position_Max. * cstand.adb, exp_pakd.adb, freeze.adb, gen_il-gen-gen_entities.adb, itypes.adb, layout.adb, sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb, sem_ch9.adb, sem_prag.adb, sem_util.adb, ttypes.ads: Update calls to routines removed from or renamed in Einfo.Utils. * uintp.ads (Upos): Fix this subtype, which was unintentionally declared to include Uint_0. patch.diff.gz Description: application/gzip
[Ada] Remove redundant checks for non-empty list of aspects
Cleanup related to inlining-for-proof and detection of overlaying actual parameters in GNATprove; semantics is unaffected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * inline.adb (Has_Excluded_Declaration): Remove redundant guard; the guarded code will call First on a No_List, which is well-defined and gives Empty.diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -4319,9 +4319,7 @@ package body Inline is -- functions, i.e. nested subprogram bodies, so inlining is not -- possible. - elsif Nkind (Decl) = N_Subtype_Declaration - and then Present (Aspect_Specifications (Decl)) - then + elsif Nkind (Decl) = N_Subtype_Declaration then declare A: Node_Id; A_Id : Aspect_Id;
[Ada] Fix shadowing in conditions for inlining
Cleanup related to inlining-for-proof and detection of overlaying actual
parameters in GNATprove; semantics is unaffected.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* inline.adb (Has_Excluded_Declaration): Rename and reduce scope
of a local variable.diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -4215,8 +4215,6 @@ package body Inline is
(Subp : Entity_Id;
Decls : List_Id) return Boolean
is
- D : Node_Id;
-
function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
-- Nested subprograms make a given body ineligible for inlining, but
-- we make an exception for instantiations of unchecked conversion.
@@ -4250,6 +4248,10 @@ package body Inline is
and then Is_Intrinsic_Subprogram (Conv);
end Is_Unchecked_Conversion;
+ -- Local variables
+
+ Decl : Node_Id;
+
-- Start of processing for Has_Excluded_Declaration
begin
@@ -4259,19 +4261,19 @@ package body Inline is
return False;
end if;
- D := First (Decls);
- while Present (D) loop
+ Decl := First (Decls);
+ while Present (Decl) loop
-- First declarations universally excluded
- if Nkind (D) = N_Package_Declaration then
+ if Nkind (Decl) = N_Package_Declaration then
Cannot_Inline
- ("cannot inline & (nested package declaration)?", D, Subp);
+ ("cannot inline & (nested package declaration)?", Decl, Subp);
return True;
- elsif Nkind (D) = N_Package_Instantiation then
+ elsif Nkind (Decl) = N_Package_Instantiation then
Cannot_Inline
- ("cannot inline & (nested package instantiation)?", D, Subp);
+ ("cannot inline & (nested package instantiation)?", Decl, Subp);
return True;
end if;
@@ -4280,51 +4282,52 @@ package body Inline is
if Back_End_Inlining then
null;
- elsif Nkind (D) = N_Task_Type_Declaration
- or else Nkind (D) = N_Single_Task_Declaration
+ elsif Nkind (Decl) = N_Task_Type_Declaration
+ or else Nkind (Decl) = N_Single_Task_Declaration
then
Cannot_Inline
- ("cannot inline & (nested task type declaration)?", D, Subp);
+ ("cannot inline & (nested task type declaration)?", Decl, Subp);
return True;
- elsif Nkind (D) = N_Protected_Type_Declaration
- or else Nkind (D) = N_Single_Protected_Declaration
+ elsif Nkind (Decl) in N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
then
Cannot_Inline
("cannot inline & (nested protected type declaration)?",
- D, Subp);
+ Decl, Subp);
return True;
- elsif Nkind (D) = N_Subprogram_Body then
+ elsif Nkind (Decl) = N_Subprogram_Body then
Cannot_Inline
- ("cannot inline & (nested subprogram)?", D, Subp);
+ ("cannot inline & (nested subprogram)?", Decl, Subp);
return True;
- elsif Nkind (D) = N_Function_Instantiation
- and then not Is_Unchecked_Conversion (D)
+ elsif Nkind (Decl) = N_Function_Instantiation
+ and then not Is_Unchecked_Conversion (Decl)
then
Cannot_Inline
- ("cannot inline & (nested function instantiation)?", D, Subp);
+ ("cannot inline & (nested function instantiation)?", Decl, Subp);
return True;
- elsif Nkind (D) = N_Procedure_Instantiation then
+ elsif Nkind (Decl) = N_Procedure_Instantiation then
Cannot_Inline
- ("cannot inline & (nested procedure instantiation)?", D, Subp);
+ ("cannot inline & (nested procedure instantiation)?",
+ Decl, Subp);
return True;
-- Subtype declarations with predicates will generate predicate
-- functions, i.e. nested subprogram bodies, so inlining is not
-- possible.
- elsif Nkind (D) = N_Subtype_Declaration
- and then Present (Aspect_Specifications (D))
+ elsif Nkind (Decl) = N_Subtype_Declaration
+ and then Present (Aspect_Specifications (Decl))
then
declare
A: Node_Id;
A_Id : Aspect_Id;
begin
- A := First (Aspect_Specifications (D));
+ A := First (Aspect_Specifications (Decl));
while Present (A) loop
A_Id := Get_Aspect_Id (Chars (Identifier (A)));
@@ -4334,7 +4337,7 @@ package body Inline is
then
Cannot_Inline
("cannot inline & (subtype declaration with "
-& "predicate)?", D, Subp)
[Ada] Present and No functions for type Uint
Declare Present and No functions for type Uint, analogous to other types such as Node_Id, and use them as appropriate. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * uintp.ads, uintp.adb (Present, No): New functions for comparing with No_Uint. * checks.adb, einfo-utils.adb, exp_aggr.adb, exp_attr.adb, exp_ch3.adb, exp_ch4.adb, exp_dbug.adb, exp_disp.adb, exp_util.adb, repinfo.adb, repinfo-input.adb, scn.adb, sem_attr.adb, sem_ch13.adb, sem_eval.adb, sem_util.adb, sinfo-utils.adb, treepr.adb: Use Present (...) instead of "... /= No_Uint", and No (...) instead of "... = No_Uint". patch.diff.gz Description: application/gzip
[Ada] Remove "with GNAT.OS_Lib;" from libgnat/a-stbufi.ads
...and replace with System.OS_Lib, because we don't want things under Ada to depend on GNAT. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/a-stbufi.ads, libgnat/a-stbufi.adb: Change all occurrences of GNAT.OS_Lib to System.OS_Lib.diff --git a/gcc/ada/libgnat/a-stbufi.adb b/gcc/ada/libgnat/a-stbufi.adb --- a/gcc/ada/libgnat/a-stbufi.adb +++ b/gcc/ada/libgnat/a-stbufi.adb @@ -45,7 +45,7 @@ package body Ada.Strings.Text_Buffers.Files is end Put_UTF_8_Implementation; function Create_From_FD - (FD : GNAT.OS_Lib.File_Descriptor; + (FD : System.OS_Lib.File_Descriptor; Close_Upon_Finalization : Boolean := True) return File_Buffer is use OS; diff --git a/gcc/ada/libgnat/a-stbufi.ads b/gcc/ada/libgnat/a-stbufi.ads --- a/gcc/ada/libgnat/a-stbufi.ads +++ b/gcc/ada/libgnat/a-stbufi.ads @@ -30,7 +30,7 @@ -- with Ada.Finalization; -with GNAT.OS_Lib; +with System.OS_Lib; package Ada.Strings.Text_Buffers.Files is @@ -38,7 +38,7 @@ package Ada.Strings.Text_Buffers.Files is -- Output written to a File_Buffer is written to the associated file. function Create_From_FD - (FD : GNAT.OS_Lib.File_Descriptor; + (FD : System.OS_Lib.File_Descriptor; Close_Upon_Finalization : Boolean := True) return File_Buffer; -- file closed upon finalization if specified @@ -47,9 +47,11 @@ package Ada.Strings.Text_Buffers.Files is -- file closed upon finalization function Create_Standard_Output_Buffer return File_Buffer is - (Create_From_FD (GNAT.OS_Lib.Standout, Close_Upon_Finalization => False)); + (Create_From_FD (System.OS_Lib.Standout, + Close_Upon_Finalization => False)); function Create_Standard_Error_Buffer return File_Buffer is - (Create_From_FD (GNAT.OS_Lib.Standerr, Close_Upon_Finalization => False)); + (Create_From_FD (System.OS_Lib.Standerr, + Close_Upon_Finalization => False)); private @@ -60,7 +62,7 @@ private package Mapping is new Output_Mapping (Put_UTF_8_Implementation); - package OS renames GNAT.OS_Lib; + package OS renames System.OS_Lib; type Self_Ref (Self : not null access File_Buffer) is new Finalization.Limited_Controlled with null record;
[Ada] Refine patch for spurious link error involving discriminated types
This patch handles properly the case of a Component_Definition appearing in a Component_Declaration. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch3.adb (Process_Discriminant_Expressions): If the constraint is for a Component_Definition that appears in a Component_Declaration, the entity to be used to create the potentially global symbol is the Defining_Identifier of the Component_Declaration.diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10502,13 +10502,30 @@ package body Sem_Ch3 is if Expander_Active and then Comes_From_Source (Def) and then not Is_Subprogram (Current_Scope) - and then Nkind (Parent (Def)) in - N_Object_Declaration | N_Component_Declaration then - Force_Evaluation ( -Discr_Expr (J), -Related_Id => Defining_Identifier (Parent (Def)), -Discr_Number => J); + declare + Id : Entity_Id := Empty; + begin + if Nkind (Parent (Def)) = N_Object_Declaration then +Id := Defining_Identifier (Parent (Def)); + + elsif Nkind (Parent (Def)) = N_Component_Definition + and then + Nkind (Parent (Parent (Def))) += N_Component_Declaration + then +Id := Defining_Identifier (Parent (Parent (Def))); + end if; + + if Present (Id) then +Force_Evaluation ( + Discr_Expr (J), + Related_Id => Id, + Discr_Number => J); + else +Force_Evaluation (Discr_Expr (J)); + end if; + end; else Force_Evaluation (Discr_Expr (J)); end if;
[Ada] Exception raised on empty file in GNATprove mode
Adapt computation of indexes in buffer for outputting error messages to avoid an index out-of-bound exception on an empty file in GNATprove mode. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * errout.adb (Get_Line_End): Do not allow the result to go past the end of the buffer.diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2473,7 +2473,8 @@ package body Errout is function Get_Line_End (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; - -- Get the source location for the end of the line in Buf for Loc + -- Get the source location for the end of the line in Buf for Loc. If + -- Loc is past the end of Buf already, return Buf'Last. function Get_Line_Start (Buf : Source_Buffer_Ptr; @@ -2515,9 +2516,9 @@ package body Errout is (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is -Cur_Loc : Source_Ptr := Loc; +Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); begin -while Cur_Loc <= Buf'Last +while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop Cur_Loc := Cur_Loc + 1;
[Ada] Update comment for Error_Msg_Internal
When Error_Msg_Internal parameters Sptr and Optr were renamed to Span and Opan, its comment has not been updated. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * errout.adb (Error_Msg_Internal): Fix references to Sptr and Optr in comment; fix grammar of "low-level" where it is used as an adjective.diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -106,15 +106,15 @@ package body Errout is Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id); - -- This is the low level routine used to post messages after dealing with + -- This is the low-level routine used to post messages after dealing with -- the issue of messages placed on instantiations (which get broken up - -- into separate calls in Error_Msg). Sptr is the location on which the + -- into separate calls in Error_Msg). Span is the location on which the -- flag will be placed in the output. In the case where the flag is on -- the template, this points directly to the template, not to one of the - -- instantiation copies of the template. Optr is the original location + -- instantiation copies of the template. Opan is the original location -- used to flag the error, and this may indeed point to an instantiation - -- copy. So typically we can see Optr pointing to the template location - -- in an instantiation copy when Sptr points to the source location of + -- copy. So typically we can see Opan pointing to the template location + -- in an instantiation copy when Span points to the source location of -- the actual instantiation (i.e the line with the new). Msg_Cont is -- set true if this is a continuation message. Node is the relevant -- Node_Id for this message, to be used to compute the enclosing entity if
[Ada] Refactor sort procedures of doubly linked list containers
In earlier work, a performance problem was addressed by rewriting Ada.Containers.Doubly_Linked_Lists.Generic_Sorting in a-cdlili.adb. It turned out that the very-slow-in-some-cases Sort algorithm formerly used there was duplicated in 4 other units: the Bounded, Formal, Indefinite, and Restricted versions. With this change, we use the better sorting algorithm in all 5 cases while reducing code duplication. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/a-costso.ads, libgnat/a-costso.adb: A new library unit, Ada.Containers.Stable_Sorting, which exports a pair of generics (one within the other) which are instantiated by each of the 5 doubly-linked list container generics to implement their respective Sort procedures. We use a pair of generics, rather than a single generic, in order to further reduce code duplication. The outer generic takes a formal private Node_Ref type representing a reference to a linked list element. For some instances, the corresponding actual parameter will be an access type; for others, it will be the index type for an array. * Makefile.rtl: Include new Ada.Containers.Stable_Sorting unit. * libgnat/a-cbdlli.adb, libgnat/a-cdlili.adb, libgnat/a-cfdlli.adb, libgnat/a-cidlli.adb, libgnat/a-crdlli.adb (Sort): Replace existing Sort implementation with a call to an instance of Ada.Containers.Stable_Sorting.Doubly_Linked_List_Sort. Declare the (trivial) actual parameters needed to declare that instance. * libgnat/a-cfdlli.ads: Fix a bug encountered during testing in the postcondition for M_Elements_Sorted. With a partial ordering, it is possible for all three of (X < Y), (Y < X), and (X = Y) to be simultaneously false, so that case needs to handled correctly. patch.diff.gz Description: application/gzip
[Ada] Enforce legality rule for Predicate_Failure aspect specifications
If a Predicate_Failure aspect is specified for a type or subtype, Ada
requires that either the Static_Predicate aspect or the
Dynamic_Predicate aspect must also be specified for that same type or
subtype. [The GNAT-defined Predicate aspect can also be used to meet
this requirement.] The point is that an aspect inherited from some other
source does not meet this requirment. Add enforcement of this legality
rule.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch13.adb (Analyze_Aspect_Specifications): Add a new nested
function, Directly_Specified, and then use it in the
implementation of the required check.diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1884,6 +1884,11 @@ package body Sem_Ch13 is
-- expression is allowed. Includes checking that the expression
-- does not raise Constraint_Error.
+function Directly_Specified
+ (Id : Entity_Id; A : Aspect_Id) return Boolean;
+-- Returns True if the given aspect is directly (as opposed to
+-- via any form of inheritance) specified for the given entity.
+
function Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id) return Node_Id;
@@ -2777,6 +2782,18 @@ package body Sem_Ch13 is
end if;
end Check_Expr_Is_OK_Static_Expression;
+
+-- Directly_Specified --
+
+
+function Directly_Specified
+ (Id : Entity_Id; A : Aspect_Id) return Boolean
+is
+ Aspect_Spec : constant Node_Id := Find_Aspect (Id, A);
+begin
+ return Present (Aspect_Spec) and then Entity (Aspect_Spec) = Id;
+end Directly_Specified;
+
---
-- Make_Aitem_Pragma --
---
@@ -3342,6 +3359,15 @@ package body Sem_Ch13 is
("Predicate_Failure requires previous predicate" &
" specification", Aspect);
goto Continue;
+
+ elsif not (Directly_Specified (E, Aspect_Dynamic_Predicate)
+or else Directly_Specified (E, Aspect_Static_Predicate)
+or else Directly_Specified (E, Aspect_Predicate))
+ then
+ Error_Msg_N
+ ("Predicate_Failure requires accompanying" &
+" noninherited predicate specification", Aspect);
+ goto Continue;
end if;
-- Construct the pragma
[Ada] Clean up uses of Esize and RM_Size
This patch updates calls to Esize and RM_Size so they will work with the new representation of "unknown" (i.e. "not yet set"). The old representation is "Uint_0". The new one will be "initial zero bits". The new representation is not yet installed; we are still using Uint_0. A future change will fix that. In some cases, we have to explicitly set the size to Uint_0 in order to preserve the old behavior. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * einfo-utils.adb: Add support (currently disabled) for using "initial zero" instead of "Uint_0" to represent "unknown". Call Known_ functions, instead of evilly duplicating their code inline. * fe.h (No_Uint_To_0): New function to convert No_Uint to Uint_0, in order to preserve existing behavior. (Copy_Esize, Copy_RM_Size): New imports from Einfo.Utils. * cstand.adb: Set size fields of Standard_Debug_Renaming_Type and Standard_Exception_Type. * checks.adb, exp_attr.adb, exp_ch3.adb, exp_ch5.adb, exp_ch6.adb, exp_pakd.adb, exp_util.adb, freeze.adb, itypes.adb, layout.adb, repinfo.adb, sem_attr.adb, sem_ch12.adb, sem_ch13.adb, sem_ch13.ads, sem_ch3.adb, sem_ch7.adb, sem_util.adb: Protect calls with Known_..., use Copy_... Remove assumption that Uint_0 represents "unknown". * types.ads (Nonzero_Int): New subtype. * gcc-interface/decl.c, gcc-interface/trans.c: Protect calls with Known_... and use Copy_... as appropriate, to avoid blowing up in unknown cases. Similarly, call No_Uint_To_0 to preserve existing behavior. patch.diff.gz Description: application/gzip
[Ada] Interface behaves differently from abstract tagged null
When the result expression of a simple-return-statement is a type conversion, and the tag of the expression differs from the tag of the specific nonlimited return type, the frontend silently skips ensuring that the tag of the returned object is that of the result type. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch6.adb (Expand_Simple_Function_Return): For explicit dereference of type conversion, enable code that ensures that the tag of the result is that of the result type.diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7437,6 +7437,10 @@ package body Exp_Ch6 is and then not Is_Class_Wide_Type (Utyp) and then (Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion +or else (Nkind (Exp) = N_Explicit_Dereference + and then Nkind (Prefix (Exp)) in + N_Type_Conversion | + N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp then
[Ada] Presence of abstract operator function causes resolution problems
The declaration of an abstract function with an operator designator can result in removing a nonhomographic user-defined operator as a possible interpretation in an overloaded expression, leading to an error about mismatched types. The condition for marking an interpretation as being a predefined operator that should be hidden by an abstract operator function was incomplete, and only checked that the result was numeric, without checking that the interpretation was actually for an operator. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch4.adb (Remove_Abstract_Operations): Add condition to test for an E_Operator as part of criteria for setting Abstract_Op on interpretations involving predefined operators.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -8029,6 +8029,7 @@ package body Sem_Ch4 is while Present (It.Nam) loop if Is_Numeric_Type (It.Typ) and then Scope (It.Typ) = Standard_Standard +and then Ekind (It.Nam) = E_Operator then Set_Abstract_Op (I, Abstract_Op); end if;
[Ada] Fix ignored dynamic predicates specified through "predicate" aspect
Before this patch, GNAT would ignore dynamic predicates specified
through the "predicate" pragma when attempting to evaluate expressions.
This would result in incorrect behavior in cases like the following:
subtype SS is String (1 .. 4) with Predicate => SS (2) = 'e';
pragma Assert ("" in SS);
Where the assert would not fail.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_eval.adb (Is_Static_Subtype): Take predicates created
through "predicate" pragma into account.diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -5741,6 +5741,8 @@ package body Sem_Eval is
elsif Has_Dynamic_Predicate_Aspect (Typ)
or else (Is_Derived_Type (Typ)
and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
+or else (Has_Aspect (Typ, Aspect_Predicate)
+ and then not Has_Static_Predicate (Typ))
then
return False;
[Ada] rtems: add 128bit support for aarch64
Add 128BITS integer support for aarch64-rtems6. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * Makefile.rtl (aarch64-rtems*): Add GNATRTL_128BIT_PAIRS to the LIBGNAT_TARGET_PAIRS list and also GNATRTL_128BIT_OBJS to the EXTRA_GNATRTL_NONTASKING_OBJS list.diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -2196,6 +2196,11 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),) EH_MECHANISM=-gcc endif + ifeq ($(strip $(filter-out aarch64%,$(target_cpu))),) +LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) +EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + ifeq ($(strip $(filter-out aarch64% riscv%,$(target_cpu))),) LIBGNAT_TARGET_PAIRS += a-nallfl.ads
[Ada] exp_pakd.adb: work around spurious Codepeer warnings
Codepeer erroneously emits a warning for this if expression. Replacing it with a statement is enough to make the problem disappear. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_pakd.adb (Expand_Packed_Not): Replace expression with statement.diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -2002,7 +2002,11 @@ package body Exp_Pakd is -- actual subtype of the operand. Preserve old behavior in case size is -- not set. - Size := (if Known_RM_Size (PAT) then RM_Size (PAT) else Uint_0); + if Known_RM_Size (PAT) then + Size := RM_Size (PAT); + else + Size := Uint_0; + end if; Lit := Make_Integer_Literal (Loc, 2 ** Size - 1); Set_Print_In_Hex (Lit);
[Ada] Follow-up tweaks to System.Dwarf_Line
This fixes a couple of thinkos in the previous change. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/s-dwalin.adb (Skip_Form): Fix cases of DW_FORM_addrx and DW_FORM_implicit_const. Replace Constraint_Error with Dwarf_Error.diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1114,8 +1114,6 @@ package body System.Dwarf_Lines is case Form is when DW_FORM_addr => Skip := Offset (Ptr_Sz); - when DW_FORM_addrx => -Skip := Offset (uint32'(Read_LEB128 (S))); when DW_FORM_block1 => Skip := Offset (uint8'(Read (S))); when DW_FORM_block2 => @@ -1161,11 +1159,12 @@ package body System.Dwarf_Lines is begin return; end; - when DW_FORM_udata -| DW_FORM_ref_udata + when DW_FORM_addrx | DW_FORM_loclistx +| DW_FORM_ref_udata | DW_FORM_rnglistx | DW_FORM_strx +| DW_FORM_udata => declare Val : constant uint32 := Read_LEB128 (S); @@ -1173,7 +1172,7 @@ package body System.Dwarf_Lines is begin return; end; - when DW_FORM_flag_present => + when DW_FORM_flag_present | DW_FORM_implicit_const => return; when DW_FORM_ref_addr | DW_FORM_sec_offset @@ -1187,10 +1186,10 @@ package body System.Dwarf_Lines is null; end loop; return; - when DW_FORM_implicit_const | DW_FORM_indirect => -raise Constraint_Error; + when DW_FORM_indirect => +raise Dwarf_Error with "DW_FORM_indirect not implemented"; when others => -raise Constraint_Error; +raise Dwarf_Error with "DWARF form not implemented"; end case; Seek (S, Tell (S) + Skip);
[Ada] Small optimization to DWARF 5 mode in System.Dwarf_Line
There is no need to fetch every string from the .debug_line_str section. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/s-dwalin.adb (To_File_Name): Fetch only the last string from the .debug_line_str section. (Symbolic_Address.Set_Result): Likewise.diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -957,8 +957,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); -Seek (C.Line_Str, Off); -Read_C_String (C.Line_Str, Buf); +if J = File then + Seek (C.Line_Str, Off); + Read_C_String (C.Line_Str, Buf); +end if; when others => raise Dwarf_Error with "DWARF form not implemented"; @@ -1674,8 +1676,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); - Seek (C.Line_Str, Off); - File_Name := Read_C_String (C.Line_Str); + if J = Match.File then + Seek (C.Line_Str, Off); + File_Name := Read_C_String (C.Line_Str); + end if; when others => raise Dwarf_Error with "DWARF form not implemented"; @@ -1718,8 +1722,10 @@ package body System.Dwarf_Lines is when DW_FORM_line_strp => Read_Section_Offset (C.Lines, Off, C.Header.Is64); - Seek (C.Line_Str, Off); - Dir_Name := Read_C_String (C.Line_Str); + if J = Dir_Idx then + Seek (C.Line_Str, Off); + Dir_Name := Read_C_String (C.Line_Str); + end if; when others => raise Dwarf_Error with "DWARF form not implemented";
[Ada] Add assertions to Uintp
Add appropriate assertions to the operations in Uintp. Most operations disallow No_Uint. Division disallows Uint_0 on the right, and so on. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * uintp.ads, uintp.adb: Add assertions. (Ubool, Opt_Ubool): New "boolean" subtypes. (UI_Is_In_Int_Range): The parameter should probably be Valid_Uint, but we don't change that for now, because it causes failures in gigi. * sem_util.ads, sem_util.adb (Is_True, Is_False, Static_Boolean): Use Opt_Ubool subtype. Document the fact that Is_True (No_Uint) = True. Implement Is_False in terms of Is_True. We considered changing Static_Boolean to return Uint_1 in case of error, but that doesn't fit in well with Static_Integer. (Has_Compatible_Alignment_Internal): Deal with cases where Offs is No_Uint. Change one "and" to "and then" to ensure we don't pass No_Uint to ">", which would violate the new assertions. * exp_util.adb, freeze.adb, sem_ch13.adb: Avoid violating new assertions in Uintp. patch.diff.gz Description: application/gzip
[Ada] Remove if_expression
Replace an if_expression with an if_statement, because codepeer is tripping over the if_expression. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_eval.adb (Fold_Shift): Replace an if_expression with an if_statement.diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5063,12 +5063,20 @@ package body Sem_Eval is -- result is always positive, even if the original operand was -- negative. - Fold_Uint - (N, - (Expr_Value (Left) + - (if Expr_Value (Left) >= Uint_0 then Uint_0 else Modulus)) - / (Uint_2 ** Expr_Value (Right)), - Static => Static); + declare + M : Unat; + begin + if Expr_Value (Left) >= Uint_0 then + M := Uint_0; + else + M := Modulus; + end if; + + Fold_Uint +(N, + (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)), + Static => Static); + end; end if; elsif Op = N_Op_Shift_Right_Arithmetic then Check_Elab_Call;
[Ada] Add assertions to Uintp (UI_Is_In_Int_Range)
This completes the previous change that added assertions to Uintp. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * uintp.ads, uintp.adb (UI_Is_In_Int_Range): Change the type of the formal parameter to Valid_Uint. Remove code that preserved the previous behavior, and replace it with an assertion. The previous behavior is no longer needed given the recent change to gigi. (No, Present): Add comment.diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -1693,16 +1693,15 @@ package body Uintp is -- UI_Is_In_Int_Range -- - - function UI_Is_In_Int_Range (Input : Uint) return Boolean is + function UI_Is_In_Int_Range (Input : Valid_Uint) return Boolean is + pragma Assert (Present (Input)); + -- Assertion is here in case we're called from C++ code, which does + -- not check the predicates. begin -- Make sure we don't get called before Initialize pragma Assert (Uint_Int_First /= Uint_0); - if No (Input) then -- Preserve old behavior - return True; - end if; - if Direct (Input) then return True; else diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -90,6 +90,10 @@ package Uintp is Uint_Minus_127 : constant Uint; Uint_Minus_128 : constant Uint; + -- Functions for detecting No_Uint. Note that clients of this package + -- cannot use "=" and "/=" to compare with No_Uint; they must use No + -- and Present instead. + function No (X : Uint) return Boolean is (X = No_Uint); -- Note that this is using the predefined "=", not the "=" declared below, -- which would blow up on No_Uint. @@ -169,10 +173,9 @@ package Uintp is pragma Inline (UI_Gt); -- Compares integer values for greater than - function UI_Is_In_Int_Range (Input : Uint) return Boolean; + function UI_Is_In_Int_Range (Input : Valid_Uint) return Boolean; pragma Inline (UI_Is_In_Int_Range); -- Determines if universal integer is in Int range. - -- Input should probably be of type Valid_Uint. function UI_Le (Left : Valid_Uint; Right : Valid_Uint) return Boolean; function UI_Le (Left : Int; Right : Valid_Uint) return Boolean;
[Ada] Cleanup old VxWorks in Makefile.rtl
The sections titled "PowerPC and e500v2 VxWorks 653" and "VxWorksae / VxWorks 653 for x86 (vxsim)" in Makefile.rtl are removed since they are no longer used. Also remove the relevant packages. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * Makefile.rtl: Remove unused VxWorks sections. * libgnarl/s-vxwext__noints.adb: Remove. * libgnarl/s-vxwext__vthreads.ads: Remove. * libgnat/a-elchha__vxworks-ppc-full.adb: Remove. * libgnat/s-osprim__vxworks.adb: Remove. * libgnat/s-osvers__vxworks-653.ads: Remove. * libgnat/system-vxworks-e500-vthread.ads: Remove. * libgnat/system-vxworks-ppc-vthread.ads: Remove. * libgnat/system-vxworks-x86-vthread.ads: Remove. patch.diff.gz Description: application/gzip
[Ada] Crash on build of Initialization procedure for derived container
This patch fixes a compiler abort on the construction of the initialization procedure for a private type completed by a derived container type whose element type is another container with controlled components with trivial initializations, Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch7.adb (Make_Init_Call): Add guard to protect against a missing initialization procedure for a type.diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -9555,8 +9555,11 @@ package body Exp_Ch7 is -- If initialization procedure for an array of controlled objects is -- trivial, do not generate a useless call to it. + -- The initialization procedure may be missing altogether in the case + -- of a derived container whose components have trivial initialization. - if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) + if No (Proc) +or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) or else (not Comes_From_Source (Proc) and then Present (Alias (Proc))
[Ada] Set related expression for external DISCR symbols in Build_Temporary
This is required for CodePeer to use a better name for a variable, or a constant created by GNAT. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_util.adb (Build_Temporary): In case of an external DISCR symbol, set the related expression for CodePeer so that a more comprehensible message can be emitted to the user.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -11656,6 +11656,7 @@ package body Exp_Util is is Temp_Id : Entity_Id; Temp_Nam : Name_Id; + Should_Set_Related_Expression : Boolean := False; begin -- The context requires an external symbol : expression is @@ -11675,6 +11676,12 @@ package body Exp_Util is else pragma Assert (Discr_Number > 0); + + -- We don't have any intelligible way of printing T_DISCR in + -- CodePeer. Thus, set a related expression in this case. + + Should_Set_Related_Expression := True; + -- Use fully qualified name to avoid ambiguities. Temp_Nam := @@ -11684,6 +11691,10 @@ package body Exp_Util is Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam); +if Should_Set_Related_Expression then + Set_Related_Expression (Temp_Id, Related_Nod); +end if; + -- Otherwise generate an internal temporary else
[Ada] Fix regression in ACATS bdd2006 and bdd2007
This fix is not strictly necessary to pass these ACATS tests, but this
improves the error message, and avoids updating expected outputs.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch13.adb (Stream_Size): Print message about allowed stream
sizes even if other error were already found. This avoids
falling into the 'else', which prints "Stream_Size cannot be
given for...", which is misleading -- the Size COULD be given if
it were correct.diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -7824,12 +7824,17 @@ package body Sem_Ch13 is
if Duplicate_Clause then
null;
-elsif Is_Elementary_Type (U_Ent) and then Present (Size) then
- if Size /= System_Storage_Unit
- and then Size /= System_Storage_Unit * 2
- and then Size /= System_Storage_Unit * 3
- and then Size /= System_Storage_Unit * 4
- and then Size /= System_Storage_Unit * 8
+elsif Is_Elementary_Type (U_Ent) then
+ -- Size will be empty if we already detected an error
+ -- (e.g. Expr is of the wrong type); we might as well
+ -- give the useful hint below even in that case.
+
+ if No (Size) or else
+ (Size /= System_Storage_Unit
+ and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 3
+ and then Size /= System_Storage_Unit * 4
+ and then Size /= System_Storage_Unit * 8)
then
Error_Msg_N
("stream size for elementary type must be 8, 16, 24, " &
[Ada] bindgen: support additional features on targets suppressing the standard lib
For targets that suppress the standard library, the binder can now set
the default stack size and enable stack checking when GCC stack limit
are used.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* bindgen.adb (Gen_Adainit): For targets that suppress the
standard library: set the default stack size global variable if
a value is provided via the -d switch, and generate a call to
__gnat_initialize_stack_limit if stack checking using stack
limits is enabled.diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -588,6 +588,27 @@ package body Bindgen is
WBI ("");
end if;
+ -- Import the default stack object if a size has been provided to the
+ -- binder.
+
+ if Opt.Default_Stack_Size /= Opt.No_Stack_Size then
+WBI (" Default_Stack_Size : Integer;");
+WBI (" pragma Import (C, Default_Stack_Size, " &
+ """__gl_default_stack_size"");");
+ end if;
+
+ -- Initialize stack limit variable of the environment task if the
+ -- stack check method is stack limit and stack check is enabled.
+
+ if Stack_Check_Limits_On_Target
+ and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ then
+WBI ("");
+WBI (" procedure Initialize_Stack_Limit;");
+WBI (" pragma Import (C, Initialize_Stack_Limit, " &
+ """__gnat_initialize_stack_limit"");");
+ end if;
+
if System_Secondary_Stack_Package_In_Closure then
-- System.Secondary_Stack is in the closure of the program
-- because the program uses the secondary stack or the restricted
@@ -619,6 +640,15 @@ package body Bindgen is
WBI (" begin");
+ -- Set the default stack size if provided to the binder
+
+ if Opt.Default_Stack_Size /= Opt.No_Stack_Size then
+Set_String (" Default_Stack_Size := ");
+Set_Int (Default_Stack_Size);
+Set_String (";");
+Write_Statement_Buffer;
+ end if;
+
if Main_Priority /= No_Main_Priority then
Set_String (" Main_Priority := ");
Set_Int(Main_Priority);
@@ -643,6 +673,7 @@ package body Bindgen is
end if;
if Main_Priority = No_Main_Priority
+ and then Opt.Default_Stack_Size = Opt.No_Stack_Size
and then Main_CPU = No_Main_CPU
and then not System_Tasking_Restricted_Stages_Used
then
[Ada] Add "optional" node subtypes that allow Empty
This patch adds new Opt_... subtypes to Sinfo.Nodes and Einfo.Entities. The predicates say "Opt_N_Declaration = Empty" rather than "No (Opt_N_Declaration)" because No is not visible. It can't be made visible with "with Atree;", because that would introduce cycles. It could be made visible by moving it to Types, but that causes a minor earthquake (changes in compiler, codepeer, and spark), so we're leaving No where it is. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * gen_il-gen.adb (Put_Opt_Subtype): Print out subtypes of the form: subtype Opt_N_Declaration is Node_Id with Predicate => Opt_N_Declaration = Empty or else Opt_N_Declaration in N_Declaration_Id; One for each node or entity type, with the predicate allowing Empty. * atree.adb (Parent, Set_Parent): Remove unnecessary "Atree.".diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1828,7 +1828,7 @@ package body Atree is function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is begin - pragma Assert (Atree.Present (N)); + pragma Assert (Present (N)); if Is_List_Member (N) then return Parent (List_Containing (N)); @@ -2151,7 +2151,7 @@ package body Atree is procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is begin - pragma Assert (Atree.Present (N)); + pragma Assert (Present (N)); pragma Assert (not In_List (N)); Set_Link (N, Union_Id (Val)); end Set_Parent; diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1405,6 +1405,10 @@ package body Gen_IL.Gen is -- Print out a subtype (of type Node_Id or Entity_Id) for a given -- nonroot abstract type. + procedure Put_Opt_Subtype (T : Node_Or_Entity_Type); + -- Print out an "optional" subtype; that is, one that allows + -- Empty. Their names start with "Opt_". + procedure Put_Enum_Type is procedure Put_Enum_Lit (T : Node_Or_Entity_Type); -- Print out one enumeration literal in the declaration of @@ -1496,6 +1500,29 @@ package body Gen_IL.Gen is end if; end Put_Id_Subtype; + procedure Put_Opt_Subtype (T : Node_Or_Entity_Type) is + begin +if Type_Table (T).Parent /= No_Type then + Put (S, "subtype Opt_" & Image (T) & " is" & LF); + Increase_Indent (S, 2); + Put (S, Id_Image (Root)); + + -- Assert that the Opt_XXX subtype is empty or in the XXX + -- subtype. + + if Enable_Assertions then + Put (S, " with Predicate =>" & LF); + Increase_Indent (S, 2); + Put (S, "Opt_" & Image (T) & " = Empty or else" & LF); + Put (S, "Opt_" & Image (T) & " in " & Id_Image (T)); + Decrease_Indent (S, 2); + end if; + + Put (S, ";" & LF); + Decrease_Indent (S, 2); +end if; + end Put_Opt_Subtype; + begin -- Put_Type_And_Subtypes Put_Enum_Type; @@ -1544,7 +1571,20 @@ package body Gen_IL.Gen is end if; end loop; - Put (S, "subtype Flag is Boolean;" & LF & LF); + Put (S, LF & "-- Optional subtypes of " & Id_Image (Root) & "." & + " These allow Empty." & LF & LF); + + Iterate_Types (Root, Pre => Put_Opt_Subtype'Access); + + Put (S, LF & "-- Optional union types:" & LF & LF); + + for T in First_Abstract (Root) .. Last_Abstract (Root) loop +if Type_Table (T) /= null and then Type_Table (T).Is_Union then + Put_Opt_Subtype (T); +end if; + end loop; + + Put (S, LF & "subtype Flag is Boolean;" & LF & LF); end Put_Type_And_Subtypes; function Low_Level_Getter_Name (T : Type_Enum) return String is
[Ada] SCOs: generate 'P' decisions for [Type_]Invariant pragmas
Those pragmas should be dealt with in the same way as their equivalent
aspects.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* par_sco.adb (Traverse_One): Add support for pragma Invariant /
Type_Invariant.diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -2248,6 +2248,8 @@ package body Par_SCO is
| Name_Loop_Invariant
| Name_Postcondition
| Name_Precondition
+| Name_Type_Invariant
+| Name_Invariant
=>
-- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note
@@ -2256,7 +2258,10 @@ package body Par_SCO is
-- on when we output the decision line in Put_SCOs,
-- depending on setting by Set_SCO_Pragma_Enabled.
-if Nam = Name_Check then
+if Nam = Name_Check
+ or else Nam = Name_Type_Invariant
+ or else Nam = Name_Invariant
+then
Next (Arg);
end if;
@@ -2285,8 +2290,7 @@ package body Par_SCO is
-- never disabled.
-- Should generate P decisions (not X) for assertion
- -- related pragmas: [Type_]Invariant,
- -- [{Static,Dynamic}_]Predicate???
+ -- related pragmas: [{Static,Dynamic}_]Predicate???
when others =>
Process_Decisions_Defer (N, 'X');
[Ada] Spurious dynamic accessibility check on allocator
This patch corrects an issue in the compiler whereby an anonymous access class-wide type allocator with default initialization has spuriously generated dynamic accessibility checks associated with the construct - leading to spurious runtime accessibility failures. Additionally, this patch corrects level miscalculations for protected components. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_util.adb (Accessibility_Level): Remove spurious special case for protected type components. * exp_ch4.adb (Generate_Accessibility_Check): Use general Accessibility_Level instead of the low-level function Type_Access_Level.diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -767,8 +767,7 @@ package body Exp_Ch4 is Cond := Make_Op_Gt (Loc, Left_Opnd => Cond, -Right_Opnd => - Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); +Right_Opnd => Accessibility_Level (N, Dynamic_Level)); -- Due to the complexity and side effects of the check, utilize an -- if statement instead of the regular Program_Error circuitry. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -728,17 +728,6 @@ package body Sem_Util is return Make_Level_Literal (Typ_Access_Level (Etype (E))); --- When E is a component of the current instance of a --- protected type, we assume the level to be deeper than that of --- the type itself. - -elsif not Is_Overloadable (E) - and then Ekind (Scope (E)) = E_Protected_Type - and then Comes_From_Source (Scope (E)) -then - return Make_Level_Literal -(Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); - -- Check if E is an expansion-generated renaming of an iterator -- by examining Related_Expression. If so, determine the -- accessibility level based on the original expression.
[Ada] Rename "optional" node subtypes that allow Empty
This patch renames the new Opt_... subtypes in Sinfo.Nodes and Einfo.Entities to end with the suffix "_Id" for homogeneity with other subtypes of Node_Id and Entity_Id. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * gen_il-gen.adb (Put_Opt_Subtype): Add suffix.diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1503,7 +1503,7 @@ package body Gen_IL.Gen is procedure Put_Opt_Subtype (T : Node_Or_Entity_Type) is begin if Type_Table (T).Parent /= No_Type then - Put (S, "subtype Opt_" & Image (T) & " is" & LF); + Put (S, "subtype Opt_" & Id_Image (T) & " is" & LF); Increase_Indent (S, 2); Put (S, Id_Image (Root)); @@ -1513,8 +1513,8 @@ package body Gen_IL.Gen is if Enable_Assertions then Put (S, " with Predicate =>" & LF); Increase_Indent (S, 2); - Put (S, "Opt_" & Image (T) & " = Empty or else" & LF); - Put (S, "Opt_" & Image (T) & " in " & Id_Image (T)); + Put (S, "Opt_" & Id_Image (T) & " = Empty or else" & LF); + Put (S, "Opt_" & Id_Image (T) & " in " & Id_Image (T)); Decrease_Indent (S, 2); end if;
