From 3c756b76327951a6c16d238c0cd0132371b7d9b3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 7 Nov 2014 14:59:41 +0100 Subject: [PATCH] [multiple changes] 2014-11-07 Arnaud Charlet * debug.adb, snames.adb-tmpl (Is_Keyword_Name): Consider 'overriding' a keyword in Ada 95 mode when -gnatd.D is used. * gnat_ugn.texi: Document -gnatd.D. 2014-11-07 Vasiliy Fofanov * gnatls.adb: Lower severity of the program's return value in some common cases. 2014-11-07 Ed Schonberg * sem_ch10.adb (Decorate_Type): The limited view of a tagged type has an empty list of primitive operations. 2014-11-07 Hristian Kirtchev * sem_ch3.adb (Analyze_Object_Declaration): Update references to SPARK RM. (Process_Full_View): Update references to SPARK RM. * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Update references to SPARK RM. (Analyze_Subprogram_Body_Helper): Update references to SPARK RM. * sem_ch7.adb (Analyze_Package_Body_Helper): Update references to SPARK RM. * sem_prag.adb (Check_Ghost_Constituent): Update references to SPARK RM. * sem_res.adb (Check_Ghost_Policy): Update references to SPARK RM. (Resolve_Actuals): Ensure that the actual parameter of a Ghost subprogram whose formal is of mode IN OUT or OUT is Ghost. * sem_util.adb (Check_Ghost_Completion): Update references to SPARK RM. 2014-11-07 Ed Schonberg * exp_ch7.adb (Make_Final_Call): If type of designated object is derived from that of the formal of the Deep_Finalize procedure, add an unchecked conversion to prevent spurious type error. 2014-11-07 Robert Dewar * table.adb, inline.adb, einfo.adb, gnat1drv.adb, exp_ch13.adb, exp_fixd.adb, prj-conf.adb, exp_strm.adb, a-cofove.adb, exp_ch3.ads: Minor reformatting. 2014-11-07 Robert Dewar * sem_ch12.adb, sem_ch13.adb, prj-tree.adb: Minor reformatting. From-SVN: r217227 --- gcc/ada/ChangeLog | 51 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-cofove.adb | 5 ++-- gcc/ada/debug.adb | 6 ++++- gcc/ada/einfo.adb | 6 ++--- gcc/ada/exp_ch13.adb | 2 +- gcc/ada/exp_ch3.ads | 8 +++---- gcc/ada/exp_ch7.adb | 12 ++++++++++ gcc/ada/exp_strm.adb | 52 ++++++++++++++++++++--------------------- gcc/ada/gnat1drv.adb | 3 +-- gcc/ada/gnat_ugn.texi | 7 ++++++ gcc/ada/gnatls.adb | 4 +++- gcc/ada/inline.adb | 2 ++ gcc/ada/prj-conf.adb | 30 +++++++++++++----------- gcc/ada/prj-tree.adb | 3 +-- gcc/ada/sem_ch10.adb | 4 +++- gcc/ada/sem_ch12.adb | 11 +++++---- gcc/ada/sem_ch13.adb | 8 +++---- gcc/ada/sem_ch3.adb | 6 ++--- gcc/ada/sem_ch6.adb | 4 ++-- gcc/ada/sem_ch7.adb | 2 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 22 ++++++++++++++++- gcc/ada/sem_util.adb | 2 +- gcc/ada/snames.adb-tmpl | 7 +++++- gcc/ada/table.adb | 4 ++++ 25 files changed, 186 insertions(+), 77 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 99ba43c1f09..f54c409d4f8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2014-11-07 Arnaud Charlet + + * debug.adb, snames.adb-tmpl (Is_Keyword_Name): Consider 'overriding' + a keyword in Ada 95 mode when -gnatd.D is used. + * gnat_ugn.texi: Document -gnatd.D. + +2014-11-07 Vasiliy Fofanov + + * gnatls.adb: Lower severity of the program's return value in + some common cases. + +2014-11-07 Ed Schonberg + + * sem_ch10.adb (Decorate_Type): The limited view of a tagged + type has an empty list of primitive operations. + +2014-11-07 Hristian Kirtchev + + * sem_ch3.adb (Analyze_Object_Declaration): Update references to SPARK + RM. + (Process_Full_View): Update references to SPARK RM. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Update references + to SPARK RM. + (Analyze_Subprogram_Body_Helper): Update references + to SPARK RM. + * sem_ch7.adb (Analyze_Package_Body_Helper): Update references + to SPARK RM. + * sem_prag.adb (Check_Ghost_Constituent): Update references to + SPARK RM. + * sem_res.adb (Check_Ghost_Policy): Update references to SPARK RM. + (Resolve_Actuals): Ensure that the actual parameter of a Ghost + subprogram whose formal is of mode IN OUT or OUT is Ghost. + * sem_util.adb (Check_Ghost_Completion): Update references to + SPARK RM. + +2014-11-07 Ed Schonberg + + * exp_ch7.adb (Make_Final_Call): If type of designated object is + derived from that of the formal of the Deep_Finalize procedure, + add an unchecked conversion to prevent spurious type error. + +2014-11-07 Robert Dewar + + * table.adb, inline.adb, einfo.adb, gnat1drv.adb, exp_ch13.adb, + exp_fixd.adb, prj-conf.adb, exp_strm.adb, a-cofove.adb, exp_ch3.ads: + Minor reformatting. + +2014-11-07 Robert Dewar + + * sem_ch12.adb, sem_ch13.adb, prj-tree.adb: Minor reformatting. + 2014-11-07 Hristian Kirtchev * einfo.adb (Set_Is_Checked_Ghost_Entity, diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 42d61f4e0e4..6776bf90fa2 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -26,7 +26,8 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; + with System; use type System.Address; package body Ada.Containers.Formal_Vectors is @@ -41,7 +42,7 @@ package body Ada.Containers.Formal_Vectors is type Elements_Array_Ptr_Const is access constant Elements_Array; procedure Free is - new Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); + new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); function Elems (Container : in out Vector) return Elements_Array_Ptr; function Elemsc diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 2b249e926e0..47371e33614 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -121,7 +121,7 @@ package body Debug is -- d.A Read/write Aspect_Specifications hash table to tree -- d.B -- d.C Generate concatenation call, do not generate inline code - -- d.D + -- d.D Disable errors on use of overriding keyword in Ada 95 mode -- d.E Turn selected errors into warnings -- d.F Debug mode for GNATprove -- d.G Ignore calls through generic formal parameters for elaboration @@ -602,6 +602,10 @@ package body Debug is -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. + -- d.D For compatibility with some Ada 95 compilers implementing only + -- one feature of Ada 2005 (overriding keyword), disable errors on use + -- of overriding keyword in Ada 95 mode. + -- d.E Turn selected errors into warnings. This debug switch causes a -- specific set of error messages into warnings. Setting this switch -- causes Opt.Error_To_Warning to be set to True. The intention is diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f9307ab9811..3e0c0c7965f 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -566,9 +566,9 @@ package body Einfo is -- Has_Static_Predicate Flag269 -- Stores_Attribute_Old_Prefix Flag270 - -- (Has_Protected) Flag271 - -- (SSO_Set_Low_By_Default) Flag272 - -- (SSO_Set_High_By_Default) Flag273 + -- Has_Protected Flag271 + -- SSO_Set_Low_By_Default Flag272 + -- SSO_Set_High_By_Default Flag273 -- Is_Generic_Actual_Subprogram Flag274 -- No_Predicate_On_Actual Flag275 -- No_Dynamic_Predicate_On_Actual Flag276 diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index fa385a0dca1..856fb74e63d 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -418,7 +418,7 @@ package body Exp_Ch13 is Apply_Address_Clause_Check (E, N); end if; - -- Analyze actions in freeze node, if any. + -- Analyze actions in freeze node, if any if Present (Actions (N)) then declare diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index f432158ed3d..3f2db942e57 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -107,10 +107,10 @@ package Exp_Ch3 is function Make_Tag_Assignment (N : Node_Id) return Node_Id; -- An object declaration that has an initialization for a tagged object -- requires a separate reassignment of the tag of the given type, because - -- the expression may include an unchecked conversion. This tag - -- assignment is inserted after the declaration, but if the object has - -- an address clause the assignment is handled as part of the freezing - -- of the object, see Check_Address_Clause. + -- the expression may include an unchecked conversion. This tag assignment + -- is inserted after the declaration, but if the object has an address + -- clause the assignment is handled as part of the freezing of the object, + -- see Check_Address_Clause. function Needs_Simple_Initialization (T : Entity_Id; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 8d5dd36aee8..4b2a4120949 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3662,6 +3662,15 @@ package body Exp_Ch7 is Set_Etype (Arg, Ftyp); return Arg; + -- Otherwise, introduce a conversion when the designated object + -- has a type derived from the formal of the controlled routine. + + elsif Is_Private_Type (Ftyp) + and then Present (Atyp) + and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp))) + then + return Unchecked_Convert_To (Ftyp, Arg); + else return Arg; end if; @@ -4769,11 +4778,14 @@ package body Exp_Ch7 is -- Generate: -- [Deep_]Finalize (Obj_Ref); + -- Set type of dereference, so that proper conversion are + -- generated when operation is inherited. Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); if Is_Access_Type (Obj_Typ) then Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Set_Etype (Obj_Ref, Directly_Designated_Type (Obj_Typ)); end if; Append_To (Stmts, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index da16134f0d2..ba0447f2820 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -1129,8 +1129,7 @@ package body Exp_Strm is -- to construct. if Has_Discriminants (Typ) - and then - No (Discriminant_Default_Value (First_Discriminant (Typ))) + and then No (Discriminant_Default_Value (First_Discriminant (Typ))) and then not Is_Constrained (Underlying_Type (B_Typ)) then Discr := First_Discriminant (B_Typ); @@ -1148,7 +1147,7 @@ package body Exp_Strm is Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), - Object_Definition => + Object_Definition => New_Occurrence_Of (Etype (Discr), Loc)); -- If this is an access discriminant, do not perform default @@ -1163,9 +1162,9 @@ package body Exp_Strm is Append_To (Decls, Decl); Append_To (Decls, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etype (Discr), Loc), + Prefix => New_Occurrence_Of (Etype (Discr), Loc), Attribute_Name => Name_Read, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Cn)))); @@ -1195,7 +1194,7 @@ package body Exp_Strm is Odef := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (B_Typ, Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constr)); @@ -1264,11 +1263,9 @@ package body Exp_Strm is -- because those are written by 'Write. if Has_Discriminants (Typ) - and then - No (Discriminant_Default_Value (First_Discriminant (Typ))) + and then No (Discriminant_Default_Value (First_Discriminant (Typ))) then Disc := First_Discriminant (Typ); - while Present (Disc) loop -- If the type is an unchecked union, it must have default @@ -1287,10 +1284,10 @@ package body Exp_Strm is Append_To (Stms, Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), Attribute_Name => Name_Write, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Disc_Ref))); @@ -1300,9 +1297,9 @@ package body Exp_Strm is Append_To (Stms, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Write, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_V)))); @@ -1448,7 +1445,7 @@ package body Exp_Strm is Append_To (Result, Make_Case_Statement (Loc, - Expression => D_Ref, + Expression => D_Ref, Alternatives => Alts)); end if; @@ -1485,10 +1482,9 @@ package body Exp_Strm is return Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Field_Typ, Loc), + Prefix => New_Occurrence_Of (Field_Typ, Loc), Attribute_Name => Nam, - Expressions => New_List ( + Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), @@ -1654,18 +1650,19 @@ package body Exp_Strm is Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => + Parameter_Type => Make_Access_Definition (Loc, Null_Exclusion_Present => True, - Subtype_Mark => New_Occurrence_Of ( - Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), + Subtype_Mark => + New_Occurrence_Of + (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), Result_Definition => New_Occurrence_Of (Typ, Loc)); Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); @@ -1698,11 +1695,12 @@ package body Exp_Strm is Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => + Parameter_Type => Make_Access_Definition (Loc, Null_Exclusion_Present => True, - Subtype_Mark => New_Occurrence_Of ( - Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), + Subtype_Mark => + New_Occurrence_Of + (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), @@ -1711,8 +1709,8 @@ package body Exp_Strm is Decl := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, + Specification => Spec, + Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 0da8a51fe78..cd6b6f48f79 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -364,8 +364,7 @@ procedure Gnat1drv is -- SPARK version of the expander. -- On the contrary, we need to enable explicitly all language checks, - -- as they may have been marked as suppressed by the use of switch - -- -gnatp + -- as they may have been suppressed by the use of switch -gnatp. Suppress_Options.Suppress := (others => False); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 1da339ad38f..9d8a5ee52f7 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3588,6 +3588,13 @@ Enforce Ada 83 restrictions. @cindex @option{-gnat95} (@command{gcc}) Enforce Ada 95 restrictions. +Note: for compatibility with some Ada 95 compilers which support only +the @code{overriding} keyword of Ada 2005, the @option{-gnatd.D} switch can +be used along with @option{-gnat95} to achieve a similar effect with GNAT. + +@option{-gnatd.D} instructs GNAT to consider @code{overriding} as a keyword +and handle its associated semantic checks, even in Ada 95 mode. + @item -gnat05 @cindex @option{-gnat05} (@command{gcc}) Allow full Ada 2005 features. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 808b00937b5..80875b52ffe 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1663,6 +1663,7 @@ begin ("Default runtime not available. Use --RTS= with a valid runtime"); Write_Eol; Write_Eol; + Exit_Status := E_Warnings; end if; Write_Str ("Source Search Path:"); @@ -1775,10 +1776,11 @@ begin Usage; else Try_Help; + Exit_Status := E_Fatal; end if; end if; - Exit_Program (E_Fatal); + Exit_Program (Exit_Status); end if; Initialize_ALI; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 812002b4ed0..3bd9b9357e1 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -496,6 +496,7 @@ package body Inline is end if; Last_Inlined := E; + else Register_Backend_Not_Inlined_Subprogram (E); end if; @@ -3323,6 +3324,7 @@ package body Inline is D := First (Decls); while Present (D) loop + -- First declarations universally excluded if Nkind (D) = N_Package_Declaration then diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index a9fd006c7ed..623cf17060c 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -1105,17 +1105,17 @@ package body Prj.Conf is if Selected_Target /= null and then Selected_Target.all /= "" + then Args (4) := new String'("--target=" & Selected_Target.all); Arg_Last := 4; + elsif Normalized_Hostname /= "" then if At_Least_One_Compiler_Command then - Args (4) := - new String'("--target=all"); + Args (4) := new String'("--target=all"); else - Args (4) := - new String'("--target=" & Normalized_Hostname); + Args (4) := new String'("--target=" & Normalized_Hostname); end if; Arg_Last := 4; @@ -1599,7 +1599,7 @@ package body Prj.Conf is Implicit_Project : Boolean := False; On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null) is - Success : Boolean := False; + Success : Boolean := False; Target_Try_Again : Boolean := True; Config_Try_Again : Boolean; @@ -1632,12 +1632,13 @@ package body Prj.Conf is Update_Ignore_Missing_With (Env.Flags, True); - Automatically_Generated := False; - -- If in fact the config file is automatically generated, + -- Note: If in fact the config file is automatically generated, then -- Automatically_Generated will be set to True after invocation of -- Process_Project_And_Apply_Config. - -- Record Target_Value and Target_Origin. + Automatically_Generated := False; + + -- Record Target_Value and Target_Origin if Target_Name = "" then Opt.Target_Value := new String'(Normalized_Hostname); @@ -2165,11 +2166,11 @@ package body Prj.Conf is Tree : Project_Tree_Ref; With_State : in out State) is - Lang_Id : Language_Ptr; + Lang_Id : Language_Ptr; Compiler_Root : Compiler_Root_Ptr; - Runtime_Root : Runtime_Root_Ptr; - Comp_Driver : String_Access; - Comp_Dir : String_Access; + Runtime_Root : Runtime_Root_Ptr; + Comp_Driver : String_Access; + Comp_Dir : String_Access; Prefix : String_Access; pragma Unreferenced (Tree); @@ -2226,8 +2227,9 @@ package body Prj.Conf is declare Runtime : constant String := - Runtime_Name_For (Lang_Id.Name); - Root : String_Access; + Runtime_Name_For (Lang_Id.Name); + Root : String_Access; + begin if Runtime'Length > 0 then if Is_Absolute_Path (Runtime) then diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 52ba0437e9e..205c23411b3 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -2458,8 +2458,7 @@ package body Prj.Tree is begin pragma Assert (Present (Node) - and then - In_Tree.Project_Nodes.Table (Node).Kind = N_Project); + and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Display_Name := To; end Set_Display_Name_Of; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 4bfd25bbb55..5479df0d1e8 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -5615,10 +5615,12 @@ package body Sem_Ch10 is Init_Size_Align (Ent); -- A tagged type and its corresponding shadow entity share one common - -- class-wide type. + -- class-wide type. The list of primitive operations for the shadow + -- entity is empty. if Is_Tagged then Set_Is_Tagged_Type (Ent); + Set_Direct_Primitive_Operations (Ent, New_Elmt_List); if No (Class_Wide_Type (Ent)) then CW_Typ := diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f982359c749..d77c1d5e13e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3454,9 +3454,10 @@ package body Sem_Ch12 is ASN : Node_Id; begin - ASN := Make_Aspect_Specification (Loc, - Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), - Expression => New_Copy (Default_Pool)); + ASN := + Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), + Expression => New_Copy (Default_Pool)); if No (Aspect_Specifications (Specification (N))) then Set_Aspect_Specifications (Specification (N), New_List (ASN)); @@ -3972,8 +3973,8 @@ package body Sem_Ch12 is ASN2 := First (Aspect_Specifications (Gen_Spec)); while Present (ASN2) loop - if Chars (Identifier (ASN2)) - = Name_Default_Storage_Pool + if Chars (Identifier (ASN2)) = + Name_Default_Storage_Pool then Remove (ASN2); exit; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index da2d6e34d8d..2ca48ef46dd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9234,10 +9234,10 @@ package body Sem_Ch13 is begin -- If rep_clauses are to be ignored, no need for legality checks. In - -- particular, no need to pester user about rep clauses that violate - -- the rule on constant addresses, given that these clauses will be - -- removed by Freeze before they reach the back end. - -- Similarly in CodePeer mode, we want to relax these checks. + -- particular, no need to pester user about rep clauses that violate the + -- rule on constant addresses, given that these clauses will be removed + -- by Freeze before they reach the back end. Similarly in CodePeer mode, + -- we want to relax these checks. if not Ignore_Rep_Clauses and not CodePeer_Mode then Check_Expr_Constants (Expr); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ed9b7b35bfa..db348d7a617 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3925,7 +3925,7 @@ package body Sem_Ch3 is -- The Ghost policy in effect at the point of declaration -- and at the point of completion must match - -- (SPARK RM 6.9(14)). + -- (SPARK RM 6.9(15)). if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) @@ -4112,7 +4112,7 @@ package body Sem_Ch3 is Set_Is_Ghost_Entity (Id); -- The Ghost policy in effect at the point of declaration and at the - -- point of completion must match (SPARK RM 6.9(14)). + -- point of completion must match (SPARK RM 6.9(16)). if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) then Check_Ghost_Completion (Prev_Entity, Id); @@ -19786,7 +19786,7 @@ package body Sem_Ch3 is Set_Is_Ghost_Entity (Full_T); -- The Ghost policy in effect at the point of declaration and at the - -- point of completion must match (SPARK RM 6.9(14)). + -- point of completion must match (SPARK RM 6.9(15)). Check_Ghost_Completion (Priv_T, Full_T); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8219728aa70..97866c0b67e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1220,7 +1220,7 @@ package body Sem_Ch6 is Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at - -- the point of completion must match (SPARK RM 6.9(14)). + -- the point of completion must match (SPARK RM 6.9(15)). Check_Ghost_Completion (Gen_Id, Body_Id); end if; @@ -3343,7 +3343,7 @@ package body Sem_Ch6 is Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and - -- at the point of completion must match (SPARK RM 6.9(14)). + -- at the point of completion must match (SPARK RM 6.9(15)). Check_Ghost_Completion (Spec_Id, Body_Id); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index b96c27af43e..ebc17a24f09 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -735,7 +735,7 @@ package body Sem_Ch7 is Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at the - -- point of completion must match (SPARK RM 6.9(14)). + -- point of completion must match (SPARK RM 6.9(15)). Check_Ghost_Completion (Spec_Id, Body_Id); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0276b5e7e33..b3e41aa8705 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -23473,7 +23473,7 @@ package body Sem_Prag is -- The Ghost policy in effect at the point of abstract -- state declaration and constituent must match - -- (SPARK RM 6.9(15)). + -- (SPARK RM 6.9(16)). if Is_Checked_Ghost_Entity (State_Id) and then Is_Ignored_Ghost_Entity (Constit_Id) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index addc32c790e..0afa28cdc86 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -841,7 +841,7 @@ package body Sem_Res is begin -- The Ghost policy in effect a the point of declaration and at the - -- point of use must match (SPARK RM 6.9(13)). + -- point of use must match (SPARK RM 6.9(14)). if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then Error_Msg_Sloc := Sloc (Err_N); @@ -4625,6 +4625,26 @@ package body Sem_Res is ("\subprogram & has Extensions_Visible True", A, Nam); end if; + -- The actual parameter of a Ghost subprogram whose formal is of + -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)). + + if Is_Ghost_Entity (Nam) + and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) + and then Is_Entity_Name (A) + and then Present (Entity (A)) + and then not Is_Ghost_Entity (Entity (A)) + then + Error_Msg_NE + ("non-ghost variable & cannot appear as actual in call to " + & "ghost procedure", A, Entity (A)); + + if Ekind (F) = E_In_Out_Parameter then + Error_Msg_N ("\corresponding formal has mode `IN OUT`", A); + else + Error_Msg_N ("\corresponding formal has mode OUT", A); + end if; + end if; + Next_Actual (A); -- Case where actual is not present diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index fc160e17d36..b3982af884e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2681,7 +2681,7 @@ package body Sem_Util is begin -- The Ghost policy in effect at the point of declaration and at the - -- point of completion must match (SPARK RM 6.9(14)). + -- point of completion must match (SPARK RM 6.9(15)). if Is_Checked_Ghost_Entity (Partial_View) and then Policy = Name_Ignore diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index a198c428af5..6e1acd9c22a 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Debug; use Debug; with Opt; use Opt; with Table; with Types; use Types; @@ -395,7 +396,11 @@ package body Snames is and then (Ada_Version >= Ada_95 or else N not in Ada_95_Reserved_Words) and then (Ada_Version >= Ada_2005 - or else N not in Ada_2005_Reserved_Words) + or else N not in Ada_2005_Reserved_Words + or else (Debug_Flag_Dot_DD and then N = Name_Overriding)) + -- Accept 'overriding' keywords if -gnatd.D is used, + -- for compatibility with Ada 95 compilers implementing + -- only this Ada 2005 extension. and then (Ada_Version >= Ada_2012 or else N not in Ada_2012_Reserved_Words); end Is_Keyword_Name; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 97d0410e6dd..4c745393b29 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -399,6 +399,10 @@ package body Table is Tree_Read_Data (Tree_Get_Table_Address, (Last_Val - Int (First) + 1) * + + -- Note the importance of parenthesizing the following division + -- to avoid the possibility of intermediate overflow. + (Table_Type'Component_Size / Storage_Unit)); end Tree_Read;