From 113522092bb252b2b5ee9e51ebd36d59677b1199 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 16 Oct 2015 12:44:09 +0200 Subject: [PATCH] [multiple changes] 2015-10-16 Javier Miranda * inline.adb (Add_Inlined_Body): Ensure that Analyze_Inlined_Bodies will be invoked after completing the analysis of the current unit. 2015-10-16 Arnaud Charlet * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Fix error message for bad last bit position. * sem_ch3.adb, sem_util.adb, sem_util.ads: Minor reformatting. 2015-10-16 Ed Schonberg * exp_ch5.adb (Expand_N_Case_Statement): If expression is compile-time known but does not obey a static predicate on its type, replace the case statement with a raise statement, as with other statically detected constraint violations. 2015-10-16 Bob Duff * s-traceb.adb, s-traceb.ads, s-traceb-hpux.adb, s-traceb-mastop.adb: Reinstate code. * opt.ads: Minor typo. From-SVN: r228866 --- gcc/ada/ChangeLog | 25 +++++++++++++++++++++++++ gcc/ada/exp_ch5.adb | 13 ++++++++++++- gcc/ada/inline.adb | 5 +++++ gcc/ada/opt.ads | 2 +- gcc/ada/s-traceb-hpux.adb | 19 +++++++++---------- gcc/ada/s-traceb-mastop.adb | 19 +++++++++---------- gcc/ada/s-traceb.adb | 11 ++++++++++- gcc/ada/s-traceb.ads | 15 +-------------- gcc/ada/sem_ch13.adb | 6 +++--- gcc/ada/sem_ch3.adb | 12 ++++++------ gcc/ada/sem_util.adb | 19 ++++++++++++++----- gcc/ada/sem_util.ads | 2 +- 12 files changed, 96 insertions(+), 52 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e31645e00ad..746c8396661 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2015-10-16 Javier Miranda + + * inline.adb (Add_Inlined_Body): Ensure that + Analyze_Inlined_Bodies will be invoked after completing the + analysis of the current unit. + +2015-10-16 Arnaud Charlet + + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Fix error + message for bad last bit position. + * sem_ch3.adb, sem_util.adb, sem_util.ads: Minor reformatting. + +2015-10-16 Ed Schonberg + + * exp_ch5.adb (Expand_N_Case_Statement): If expression is + compile-time known but does not obey a static predicate on + its type, replace the case statement with a raise statement, + as with other statically detected constraint violations. + +2015-10-16 Bob Duff + + * s-traceb.adb, s-traceb.ads, s-traceb-hpux.adb, s-traceb-mastop.adb: + Reinstate code. + * opt.ads: Minor typo. + 2015-10-16 Ed Schonberg * sem_util.adb (Gather_Components): When gathering components diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7156c76a8ef..8cb77332636 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2590,9 +2590,20 @@ package body Exp_Ch5 is -- If the value is static but its subtype is predicated and the value -- does not obey the predicate, the value is marked non-static, and - -- there can be no corresponding static alternative. + -- there can be no corresponding static alternative. In that case we + -- replace the case statement with an exception, regardless of whether + -- assertions are enabled or not. if Compile_Time_Known_Value (Expr) + and then Has_Predicates (Etype (Expr)) + and then not Is_OK_Static_Expression (Expr) + then + Rewrite (N, + Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data)); + Analyze (N); + return; + + elsif Compile_Time_Known_Value (Expr) and then (not Has_Predicates (Etype (Expr)) or else Is_Static_Expression (Expr)) then diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b36ec52908e..398a466f1c2 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -405,6 +405,11 @@ package body Inline is Pack : constant Entity_Id := Get_Code_Unit_Entity (E); begin + -- Ensure that Analyze_Inlined_Bodies will be invoked after + -- completing the analysis of the current unit. + + Inline_Processing_Required := True; + if Pack = E then -- Library-level inlined function. Add function itself to diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 301b5510d59..b768be4075d 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -819,7 +819,7 @@ package Opt is -- be inlined in GNATprove mode. Init_Or_Norm_Scalars : Boolean := False; - -- GNAT, GANTBIND + -- GNAT, GNATBIND -- Set True if a pragma Initialize_Scalars applies to the current unit. -- Also set True if a pragma Restriction (Normalize_Scalars) applies. diff --git a/gcc/ada/s-traceb-hpux.adb b/gcc/ada/s-traceb-hpux.adb index 9987cb3fe64..dcd6ad0b64f 100644 --- a/gcc/ada/s-traceb-hpux.adb +++ b/gcc/ada/s-traceb-hpux.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2015, 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- -- @@ -262,15 +262,14 @@ package body System.Traceback is -- but it is not usable when frames with dynamically allocated space are -- on the way. --- procedure Call_Chain --- (Traceback : System.Address; --- Max_Len : Natural; --- Len : out Natural; --- Exclude_Min : System.Address := System.Null_Address; --- Exclude_Max : System.Address := System.Null_Address; --- Skip_Frames : Natural := 1); --- -- Same as the exported version, but takes Traceback as an Address --- ???See declaration in the spec for why this is temporarily commented out. + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address ------------------ -- C_Call_Chain -- diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb index 0ce7c50f933..1a00d97f1e6 100644 --- a/gcc/ada/s-traceb-mastop.adb +++ b/gcc/ada/s-traceb-mastop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,15 +37,14 @@ package body System.Traceback is use System.Machine_State_Operations; --- procedure Call_Chain --- (Traceback : System.Address; --- Max_Len : Natural; --- Len : out Natural; --- Exclude_Min : System.Address := System.Null_Address; --- Exclude_Max : System.Address := System.Null_Address; --- Skip_Frames : Natural := 1); --- -- Same as the exported version, but takes Traceback as an Address --- ???See declaration in the spec for why this is temporarily commented out. + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address ---------------- -- Call_Chain -- diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb index 4855644434e..e4671135ade 100644 --- a/gcc/ada/s-traceb.adb +++ b/gcc/ada/s-traceb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -38,6 +38,15 @@ pragma Compiler_Unit_Warning; package body System.Traceback is + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + ------------------ -- C_Call_Chain -- ------------------ diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads index dbfea6a6f6f..283bd5cd072 100644 --- a/gcc/ada/s-traceb.ads +++ b/gcc/ada/s-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -78,19 +78,6 @@ package System.Traceback is -- number of stored entries. The first entry is the most recent call, -- and the last entry is the highest level call. - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the previous version, but takes Traceback as an Address. The - -- previous version is preferred. ???This version should be removed from - -- this spec, and calls replaced with calls to the previous version. This - -- declaration can be moved to the bodies (s-traceb.adb, s-traceb-hpux.adb, - -- and s-traceb-mastop.adb), but it should not be visible to clients. - function C_Call_Chain (Traceback : System.Address; Max_Len : Natural) return Natural; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5494d332184..f532595075b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -471,10 +471,10 @@ package body Sem_Ch13 is ("machine scalar rules not followed for&", First_Bit (CC), Comp); - Error_Msg_Uint_1 := Lbit; + Error_Msg_Uint_1 := Lbit + 1; Error_Msg_Uint_2 := Max_Machine_Scalar_Size; Error_Msg_F - ("\last bit (^) exceeds maximum machine " + ("\last bit + 1 (^) exceeds maximum machine " & "scalar size (^)", First_Bit (CC)); @@ -482,7 +482,7 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := SSU; Error_Msg_F ("\and is not a multiple of Storage_Unit (^) " - & "(RM 13.4.1(10))", + & "(RM 13.5.1(10))", First_Bit (CC)); else diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f163b1581b2..62cc79105a1 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -17945,9 +17945,9 @@ package body Sem_Ch3 is (C : Entity_Id; N : Node_Id := Empty) return Boolean is - Original_Comp : Entity_Id := Empty; + Original_Comp : Entity_Id := Empty; Original_Type : Entity_Id; - Type_Scope : Entity_Id; + Type_Scope : Entity_Id; function Is_Local_Type (Typ : Entity_Id) return Boolean; -- Check whether parent type of inherited component is declared locally, @@ -18088,9 +18088,9 @@ package body Sem_Ch3 is if Ancestor = Original_Type then return True; - -- The ancestor may have a partial view of the original - -- type, but if the full view is in scope, as in a child - -- body, the component is visible. + -- The ancestor may have a partial view of the original type, + -- but if the full view is in scope, as in a child body, the + -- component is visible. elsif In_Private_Part (Scope (Original_Type)) and then Full_View (Ancestor) = Original_Type @@ -18099,7 +18099,7 @@ package body Sem_Ch3 is elsif Ancestor = Etype (Ancestor) then - -- No further ancestors to examine. + -- No further ancestors to examine return False; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 56f4d9378ca..4903d3f4dae 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17109,6 +17109,10 @@ package body Sem_Util is -- This shouldn't be necessary, but without this check, we crash in -- gimplify. ??? + ------------------------------ + -- Caller_Known_Size_Record -- + ------------------------------ + function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); @@ -17118,9 +17122,10 @@ package body Sem_Util is end if; declare - Comp : Entity_Id := First_Entity (Typ); + Comp : Entity_Id; begin + Comp := First_Entity (Typ); while Present (Comp) loop -- Only look at E_Component entities. No need to look at @@ -17156,6 +17161,10 @@ package body Sem_Util is return True; end Caller_Known_Size_Record; + --------------------------- + -- Has_Discrim_Dep_Array -- + --------------------------- + function Has_Discrim_Dep_Array (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); @@ -17165,13 +17174,14 @@ package body Sem_Util is end if; if Is_Record_Type (Typ) - or else - Is_Protected_Type (Typ) + or else + Is_Protected_Type (Typ) then declare - Comp : Entity_Id := First_Entity (Typ); + Comp : Entity_Id; begin + Comp := First_Entity (Typ); while Present (Comp) loop -- Only look at E_Component entities. No need to look at @@ -17182,7 +17192,6 @@ package body Sem_Util is declare Comp_Type : constant Entity_Id := Underlying_Type (Etype (Comp)); - begin if Has_Discrim_Dep_Array (Comp_Type) then return True; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 650731746bf..28f0b34f2f6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -823,7 +823,7 @@ package Sem_Util is -- returned. Otherwise the Etype of the node is returned. function Get_Body_From_Stub (N : Node_Id) return Node_Id; - -- Return the body node for a stub. + -- Return the body node for a stub function Get_Cursor_Type (Aspect : Node_Id; -- 2.30.2