From 8ef30a2395b23109b53f82de6f09143289aecce1 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 29 Aug 2011 12:52:57 +0000 Subject: [PATCH] 2011-08-29 Tristan Gingold * a-exstat.adb (String_To_EO): Do no set Cleanup_Flag. * a-exexda.adb (Set_Exception_C_Msg): Ditto. (Set_Exception_Msg): Ditto. * a-exexpr-gcc.adb (Setup_Current_Excep): Ditto. Do not set Private_Data. * a-except.adb, a-except-2005.adb (Save_Occurrence_No_Private): Remove. Use Save_Occurrence instead of Save_Occurrence_No_Private. (Raise_With_Msg): Remove Cleanup_Flag. * a-except.ads, a-except-2005.ads (Exception_Occurrence): Remove Clean_Flag and Private_Data components. 2011-08-29 Yannick Moy * freeze.adb (Freeze_Record_Type): Ignore packing in Alfa mode, like in CodePeer mode. * sem_ch3.adb (Signed_Integer_Type_Declaration): Correct the generation of an explicitly declared type, so that the base types of the original type and this generated type are the same, and a "type" (not a subtype like previously). * errout.adb (Special_Msg_Delete): Do not issue messages "Size too small" in Alfa mode, like in CodePeer mode. * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ignore rep clauses in Alfa mode. 2011-08-29 Javier Miranda * exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this function to the package spec. * sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For internally generated bodies of null procedures locate the internally generated spec enforcing mode conformance. (Is_Interface_Conformant): Ensure that the controlling formal of the primitives match. 2011-08-29 Ed Schonberg * sem_prag.adb (Analyze_Pragma, case Inline): In an instance, do not reject the pragma if it appears to apply to a formal subprogram. 2011-08-29 Ed Schonberg * exp_ch4.adb (Expand_Allocator_Expression): Use consistent name for inner expression, to prevent double evaluation. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178216 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 46 ++++++++++++++++++++++++++++++++++ gcc/ada/a-except-2005.adb | 50 +++++++++---------------------------- gcc/ada/a-except-2005.ads | 16 +----------- gcc/ada/a-except.adb | 56 +++++++++-------------------------------- gcc/ada/a-except.ads | 16 +----------- gcc/ada/a-exexda.adb | 2 -- gcc/ada/a-exexpr-gcc.adb | 2 -- gcc/ada/a-exstat.adb | 4 +-- gcc/ada/errout.adb | 6 ++--- gcc/ada/exp_ch4.adb | 3 ++- gcc/ada/exp_ch6.adb | 4 --- gcc/ada/exp_ch6.ads | 4 +++ gcc/ada/freeze.adb | 11 ++++++--- gcc/ada/sem_ch13.adb | 9 ++++--- gcc/ada/sem_ch3.adb | 7 +++--- gcc/ada/sem_ch6.adb | 63 ++++++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_prag.adb | 3 +++ 17 files changed, 161 insertions(+), 141 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9a68b31c2b9..c84d5230ac4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,51 @@ 2011-08-29 Tristan Gingold + * a-exstat.adb (String_To_EO): Do no set Cleanup_Flag. + * a-exexda.adb (Set_Exception_C_Msg): Ditto. + (Set_Exception_Msg): Ditto. + * a-exexpr-gcc.adb (Setup_Current_Excep): Ditto. Do not set + Private_Data. + * a-except.adb, a-except-2005.adb (Save_Occurrence_No_Private): Remove. + Use Save_Occurrence instead of Save_Occurrence_No_Private. + (Raise_With_Msg): Remove Cleanup_Flag. + * a-except.ads, a-except-2005.ads (Exception_Occurrence): Remove + Clean_Flag and Private_Data components. + +2011-08-29 Yannick Moy + + * freeze.adb (Freeze_Record_Type): Ignore packing in Alfa mode, like + in CodePeer mode. + * sem_ch3.adb (Signed_Integer_Type_Declaration): Correct the generation + of an explicitly declared type, so that the base types of the original + type and this generated type are the same, and a "type" (not a subtype + like previously). + * errout.adb (Special_Msg_Delete): Do not issue messages "Size too + small" in Alfa mode, like in CodePeer mode. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ignore rep + clauses in Alfa mode. + +2011-08-29 Javier Miranda + + * exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this + function to the package spec. + * sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For + internally generated bodies of null procedures locate the internally + generated spec enforcing mode conformance. + (Is_Interface_Conformant): Ensure that the controlling formal of the + primitives match. + +2011-08-29 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Inline): In an instance, do not + reject the pragma if it appears to apply to a formal subprogram. + +2011-08-29 Ed Schonberg + + * exp_ch4.adb (Expand_Allocator_Expression): Use consistent name for + inner expression, to prevent double evaluation. + +2011-08-29 Tristan Gingold + * a-exexpr.adb (Propagate_Exception): Remove all the parameters as they were unused. * a-exexpr-gcc.adb (Propagate_Exception): Ditto. diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index e45466e4071..6dbdeba0b75 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -380,18 +380,6 @@ package body Ada.Exceptions is -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. - -- Save_Occurrence variations: As the management of the private data - -- attached to occurrences is delicate, whether or not pointers to such - -- data has to be copied in various situations is better made explicit. - -- The following procedures provide an internal interface to help making - -- this explicit. - - procedure Save_Occurrence_No_Private - (Target : out Exception_Occurrence; - Source : Exception_Occurrence); - -- Copy all the components of Source to Target, except the - -- Private_Data pointer. - procedure Transfer_Occurrence (Target : Exception_Occurrence_Access; Source : Exception_Occurrence); @@ -1006,7 +994,6 @@ package body Ada.Exceptions is Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; - Excep.Cleanup_Flag := False; Excep.Pid := Local_Partition_ID; -- The following is a common pattern, should be abstracted @@ -1274,7 +1261,7 @@ package body Ada.Exceptions is Abort_Defer.all; end if; - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; @@ -1289,7 +1276,7 @@ package body Ada.Exceptions is Abort_Defer.all; end if; - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; @@ -1299,7 +1286,7 @@ package body Ada.Exceptions is procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; @@ -1312,37 +1299,24 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - Save_Occurrence_No_Private (Target, Source); - end Save_Occurrence; - - function Save_Occurrence (Source : Exception_Occurrence) return EOA is - Target : constant EOA := new Exception_Occurrence; - begin - Save_Occurrence (Target.all, Source); - return Target; - end Save_Occurrence; - - -------------------------------- - -- Save_Occurrence_No_Private -- - -------------------------------- - - procedure Save_Occurrence_No_Private - (Target : out Exception_Occurrence; - Source : Exception_Occurrence) - is - begin Target.Id := Source.Id; Target.Msg_Length := Source.Msg_Length; Target.Num_Tracebacks := Source.Num_Tracebacks; Target.Pid := Source.Pid; - Target.Cleanup_Flag := Source.Cleanup_Flag; Target.Msg (1 .. Target.Msg_Length) := Source.Msg (1 .. Target.Msg_Length); Target.Tracebacks (1 .. Target.Num_Tracebacks) := Source.Tracebacks (1 .. Target.Num_Tracebacks); - end Save_Occurrence_No_Private; + end Save_Occurrence; + + function Save_Occurrence (Source : Exception_Occurrence) return EOA is + Target : constant EOA := new Exception_Occurrence; + begin + Save_Occurrence (Target.all, Source); + return Target; + end Save_Occurrence; ------------------------- -- Transfer_Occurrence -- @@ -1353,7 +1327,7 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - Save_Occurrence_No_Private (Target.all, Source); + Save_Occurrence (Target.all, Source); end Transfer_Occurrence; ------------------- diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index f4cdebb47de..aed0f208754 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -301,13 +301,6 @@ private Msg : String (1 .. Exception_Msg_Max_Length); -- Characters of message - Cleanup_Flag : Boolean := False; - -- The cleanup flag is normally False, it is set True for an exception - -- occurrence passed to a cleanup routine, and will still be set True - -- when the cleanup routine does a Reraise_Occurrence call using this - -- exception occurrence. This is used to avoid recording a bogus trace - -- back entry from this reraise call. - Exception_Raised : Boolean := False; -- Set to true to indicate that this exception occurrence has actually -- been raised. When an exception occurrence is first created, this is @@ -325,11 +318,6 @@ private Tracebacks : Tracebacks_Array; -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) - - Private_Data : System.Address := System.Null_Address; - -- Field used by low level exception mechanism to store specific data. - -- Currently used by the GCC exception mechanism to store a pointer to - -- a GNAT_GCC_Exception. end record; function "=" (Left, Right : Exception_Occurrence) return Boolean @@ -347,11 +335,9 @@ private Id => null, Msg_Length => 0, Msg => (others => ' '), - Cleanup_Flag => False, Exception_Raised => False, Pid => 0, Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry), - Private_Data => System.Null_Address); + Tracebacks => (others => TBE.Null_TB_Entry)); end Ada.Exceptions; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 44ccc9a58f7..4d5d181786f 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -341,18 +341,6 @@ package body Ada.Exceptions is -- (all fields of this exception occurrence are set). Abort is deferred -- before the reraise operation. - -- Save_Occurrence variations: As the management of the private data - -- attached to occurrences is delicate, whether or not pointers to such - -- data has to be copied in various situations is better made explicit. - -- The following procedures provide an internal interface to help making - -- this explicit. - - procedure Save_Occurrence_No_Private - (Target : out Exception_Occurrence; - Source : Exception_Occurrence); - -- Copy all the components of Source to Target, except the - -- Private_Data pointer. - procedure Transfer_Occurrence (Target : Exception_Occurrence_Access; Source : Exception_Occurrence); @@ -959,7 +947,6 @@ package body Ada.Exceptions is Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; - Excep.Cleanup_Flag := False; Excep.Pid := Local_Partition_ID; Abort_Defer.all; Raise_Current_Excep (E); @@ -1164,7 +1151,7 @@ package body Ada.Exceptions is begin if X.Id /= null then Abort_Defer.all; - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; @@ -1176,7 +1163,7 @@ package body Ada.Exceptions is procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin Abort_Defer.all; - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; @@ -1186,7 +1173,7 @@ package body Ada.Exceptions is procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin - Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); + Save_Occurrence (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; @@ -1199,37 +1186,24 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - Save_Occurrence_No_Private (Target, Source); - end Save_Occurrence; - - function Save_Occurrence (Source : Exception_Occurrence) return EOA is - Target : constant EOA := new Exception_Occurrence; - begin - Save_Occurrence (Target.all, Source); - return Target; - end Save_Occurrence; - - -------------------------------- - -- Save_Occurrence_No_Private -- - -------------------------------- - - procedure Save_Occurrence_No_Private - (Target : out Exception_Occurrence; - Source : Exception_Occurrence) - is - begin Target.Id := Source.Id; Target.Msg_Length := Source.Msg_Length; Target.Num_Tracebacks := Source.Num_Tracebacks; Target.Pid := Source.Pid; - Target.Cleanup_Flag := Source.Cleanup_Flag; Target.Msg (1 .. Target.Msg_Length) := Source.Msg (1 .. Target.Msg_Length); Target.Tracebacks (1 .. Target.Num_Tracebacks) := Source.Tracebacks (1 .. Target.Num_Tracebacks); - end Save_Occurrence_No_Private; + end Save_Occurrence; + + function Save_Occurrence (Source : Exception_Occurrence) return EOA is + Target : constant EOA := new Exception_Occurrence; + begin + Save_Occurrence (Target.all, Source); + return Target; + end Save_Occurrence; ------------------------- -- Transfer_Occurrence -- @@ -1240,13 +1214,7 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - -- Setup Target as an exception to be propagated in the calling task - -- (rendezvous-wise), taking care not to clobber the associated private - -- data. Target is expected to be a pointer to the calling task's fixed - -- TSD occurrence, which is very different from Get_Current_Excep here - -- because this subprogram is called from the called task. - - Save_Occurrence_No_Private (Target.all, Source); + Save_Occurrence (Target.all, Source); end Transfer_Occurrence; ------------------- diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 0ff3ee6773d..22f0cee9beb 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -271,13 +271,6 @@ private Msg : String (1 .. Exception_Msg_Max_Length); -- Characters of message - Cleanup_Flag : Boolean := False; - -- The cleanup flag is normally False, it is set True for an exception - -- occurrence passed to a cleanup routine, and will still be set True - -- when the cleanup routine does a Reraise_Occurrence call using this - -- exception occurrence. This is used to avoid recording a bogus trace - -- back entry from this reraise call. - Exception_Raised : Boolean := False; -- Set to true to indicate that this exception occurrence has actually -- been raised. When an exception occurrence is first created, this is @@ -295,11 +288,6 @@ private Tracebacks : Tracebacks_Array; -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) - - Private_Data : System.Address := System.Null_Address; - -- Field used by low level exception mechanism to store specific data. - -- Currently used by the GCC exception mechanism to store a pointer to - -- a GNAT_GCC_Exception. end record; function "=" (Left, Right : Exception_Occurrence) return Boolean @@ -317,11 +305,9 @@ private Id => null, Msg_Length => 0, Msg => (others => ' '), - Cleanup_Flag => False, Exception_Raised => False, Pid => 0, Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry), - Private_Data => System.Null_Address); + Tracebacks => (others => TBE.Null_TB_Entry)); end Ada.Exceptions; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index b035ebdf6b0..69a1accc465 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -617,7 +617,6 @@ package body Exception_Data is Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; Excep.Msg_Length := 0; - Excep.Cleanup_Flag := False; while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length @@ -668,7 +667,6 @@ package body Exception_Data is Excep.Id := Id; Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; - Excep.Cleanup_Flag := False; end Set_Exception_Msg; diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index a433dddf71c..7a460e07738 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -350,11 +350,9 @@ package body Exception_Propagation is Excep.Id := Foreign_Exception'Access; Excep.Msg_Length := 0; - Excep.Cleanup_Flag := False; Excep.Exception_Raised := True; Excep.Pid := Local_Partition_ID; Excep.Num_Tracebacks := 0; - Excep.Private_Data := System.Null_Address; end if; end Setup_Current_Excep; diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb index 79ab578624c..f5674e5e867 100644 --- a/gcc/ada/a-exstat.adb +++ b/gcc/ada/a-exstat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -144,8 +144,6 @@ package body Stream_Attributes is return Null_Occurrence; else - X.Cleanup_Flag := False; - To := S'First - 2; Next_String; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 6a6142d4121..3f9acbfb98e 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2832,10 +2832,10 @@ package body Errout is elsif Msg = "size for& too small, minimum allowed is ^" then - -- Suppress "size too small" errors in CodePeer mode, since pragma - -- Pack is also ignored in this configuration. + -- Suppress "size too small" errors in CodePeer mode and ALFA mode, + -- since pragma Pack is also ignored in this configuration. - if CodePeer_Mode then + if CodePeer_Mode or ALFA_Mode then return True; -- When a size is wrong for a frozen type there is no explicit size diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3c42b646730..637e544bcea 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1165,7 +1165,8 @@ package body Exp_Ch4 is Insert_Action (Exp, Make_Subtype_Declaration (Loc, Defining_Identifier => ConstrT, - Subtype_Indication => Make_Subtype_From_Expr (Exp, T))); + Subtype_Indication => + Make_Subtype_From_Expr (Internal_Exp, T))); Freeze_Itype (ConstrT, Exp); Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); end; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 5f8feb73bf0..49e471d5f03 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -223,10 +223,6 @@ package body Exp_Ch6 is -- reference to the object itself, and the call becomes a call to the -- corresponding protected subprogram. - function Is_Null_Procedure (Subp : Entity_Id) return Boolean; - -- Predicate to recognize stubbed procedures and null procedures, which - -- can be inlined unconditionally in all cases. - procedure Expand_Simple_Function_Return (N : Node_Id); -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 077ddeb9e19..1896ce21069 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -119,6 +119,10 @@ package Exp_Ch6 is -- that requires handling as a build-in-place call or is a qualified -- expression applied to such a call; otherwise returns False. + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; + -- Predicate to recognize stubbed procedures and null procedures, which + -- can be inlined unconditionally in all cases. + procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 3917aa40aa1..e4c56948fe6 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2246,12 +2246,14 @@ package body Freeze is and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size - -- Never do implicit packing in CodePeer mode since we don't do - -- any packing in this mode, since this generates over-complex - -- code that confuses CodePeer, and in general, CodePeer does not - -- care about the internal representation of objects. + -- Never do implicit packing in CodePeer or ALFA modes since + -- we don't do any packing in this mode, since this generates + -- over-complex code that confuses static analysis, and in + -- general, neither CodePeer not GNATprove care about the + -- internal representation of objects. and then not CodePeer_Mode + and then not ALFA_Mode then -- If implicit packing enabled, do it @@ -3066,6 +3068,7 @@ package body Freeze is and then not Is_Packed (Root_Type (E)) and then not Has_Component_Size_Clause (Root_Type (E)) and then not CodePeer_Mode + and then not ALFA_Mode then Get_Index_Bounds (First_Index (E), Lo, Hi); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index db7e37bbb36..fcece69bbfe 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2004,9 +2004,10 @@ package body Sem_Ch13 is end if; -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in - -- CodePeer mode, since they are not relevant in that context). + -- CodePeer mode or ALFA mode, since they are not relevant in these + -- contexts). - if Ignore_Rep_Clauses or CodePeer_Mode then + if Ignore_Rep_Clauses or CodePeer_Mode or ALFA_Mode then case Id is -- The following should be ignored. They do not affect legality @@ -2026,8 +2027,8 @@ package body Sem_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); return; - -- We do not want too ignore 'Small in CodePeer_Mode, since it - -- has an impact on the exact computations performed. + -- We do not want too ignore 'Small in CodePeer_Mode or ALFA_Mode, + -- since it has an impact on the exact computations performed. -- Perhaps 'Small should also not be ignored by -- Ignore_Rep_Clauses ??? diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 13e0fdbb0c0..2ab8ab1bf4f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19771,14 +19771,14 @@ package body Sem_Ch3 is if ALFA_Mode then -- If the range of the type is already symmetric with a possible - -- extra negative value, just make the type its own base type. + -- extra negative value, leave it this way. if UI_Le (Lo_Val, Hi_Val) and then (UI_Eq (Lo_Val, UI_Negate (Hi_Val)) or else UI_Eq (Lo_Val, UI_Sub (UI_Negate (Hi_Val), Uint_1))) then - Set_Etype (T, T); + null; else declare @@ -19830,7 +19830,8 @@ package body Sem_Ch3 is High_Bound => Ubound)); Analyze (Decl); - Set_Etype (Implicit_Base, Implicit_Base); + Set_Etype (Implicit_Base, Base_Type (Implicit_Base)); + Set_Etype (T, Base_Type (Implicit_Base)); Insert_Before (Parent (Def), Decl); end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 165ce9f849b..d6eb55da231 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6362,7 +6362,19 @@ package body Sem_Ch6 is end if; end if; - if not Has_Completion (E) then + -- Ada 2012 (AI05-0165): For internally generated bodies of + -- null procedures locate the internally generated spec. We + -- enforce mode conformance since a tagged type may inherit + -- from interfaces several null primitives which differ only + -- in the mode of the formals. + + if not (Comes_From_Source (E)) + and then Is_Null_Procedure (E) + and then not Mode_Conformant (Designator, E) + then + null; + + elsif not Has_Completion (E) then if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); end if; @@ -7037,6 +7049,30 @@ package body Sem_Ch6 is Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + function Controlling_Formal (Prim : Entity_Id) return Entity_Id; + -- Return the controlling formal of Prim + + function Controlling_Formal (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := First_Entity (Prim); + begin + while Present (E) loop + if Is_Formal (E) and then Is_Controlling_Formal (E) then + return E; + end if; + + Next_Entity (E); + end loop; + + return Empty; + end Controlling_Formal; + + -- Local variables + + Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim); + Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim); + + -- Start of processing for Is_Interface_Conformant + begin pragma Assert (Is_Subprogram (Iface_Prim) and then Is_Subprogram (Prim) @@ -7060,8 +7096,17 @@ package body Sem_Ch6 is then return False; - -- Case of a procedure, or a function that does not have a controlling - -- result (I or access I). + -- The mode of the controlling formals must match + + elsif Present (Iface_Ctrl_F) + and then Present (Prim_Ctrl_F) + and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F) + then + return False; + + -- Case of a procedure, or a function whose result type matches the + -- result type of the interface primitive, or a function that has no + -- controlling result (I or access I). elsif Ekind (Iface_Prim) = E_Procedure or else Etype (Prim) = Etype (Iface_Prim) @@ -8254,6 +8299,18 @@ package body Sem_Ch6 is if Scope (E) /= Current_Scope then null; + -- Ada 2012 (AI05-0165): For internally generated bodies of + -- null procedures locate the internally generated spec. We + -- enforce mode conformance since a tagged type may inherit + -- from interfaces several null primitives which differ only + -- in the mode of the formals. + + elsif not Comes_From_Source (S) + and then Is_Null_Procedure (S) + and then not Mode_Conformant (E, S) + then + null; + -- Check if we have type conformance elsif Type_Conformant (E, S) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7f51294e2a2..8bf98ba7ea9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4694,9 +4694,12 @@ package body Sem_Prag is -- Inline is a program unit pragma (RM 10.1.5) and cannot -- appear in a formal part to apply to a formal subprogram. + -- Do not apply check within an instance or a formal package + -- the test will have been applied to the original generic. elsif Nkind (Decl) in N_Formal_Subprogram_Declaration and then List_Containing (Decl) = List_Containing (N) + and then not In_Instance then Error_Msg_N ("Inline cannot apply to a formal subprogram", N); -- 2.11.0