From 7727a9c182e4e12878b2e4703563cc68a695653d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 6 Jan 2017 11:43:33 +0100 Subject: [PATCH] [multiple changes] 2017-01-06 Justin Squirek * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Remove declaration generation in the case of System_Tasking_Protected_Objects_Single_Entry being used, and add a warning message when this is detected to occur. (Make_Initialize_Protection): Remove reference pass in the case of System_Tasking_Protected_Objects_Single_Entry. * rtsfind.ads: Remove RE_Protected_Entry_Queue_Max * s-tposen.adb (Initialize_Protection_Entry): Remove Entry_Queue_Max parameter. * s-tposen.ads: Remove the types use to store the entry queue maximum. * sem_prag.adb (Analyze_Pragma): Remove entry families restriction 2017-01-06 Yannick Moy * sem_util.adb, sem_util.ads (Get_Enum_Lit_From_Pos): Strengthen behavior of function, to also accept out of range positions and raise Constraint_Error in such case, and to copy sloc from literal if No_Location passed as location. * uintp.adb, uintp.ads (UI_To_Int, UI_To_CC): Strengthen behavior of functions to raise Constraint_Error in case of value not in appropriate range. 2017-01-06 Tristan Gingold * sem_util.adb, s-taprop-linux.adb (Finalize_TCB): Remove call to Invalidate_Stack_Cache. 2017-01-06 Eric Botcazou * s-os_lib.adb: Minor fix to the signature of Readlink. 2017-01-06 Javier Miranda * sem_ch6.adb (Conforming_Types): Handle another confusion between views in a nested instance with an actual private type whose full view is not in scope. 2017-01-06 Arnaud Charlet * exp_ch5.adb (Expand_N_If_Statement): Obey existing comment and mark a rewritten if statement as explicit (Comes_From_Source). From-SVN: r244128 --- gcc/ada/ChangeLog | 45 +++++++++++++++ gcc/ada/exp_ch5.adb | 13 +++-- gcc/ada/exp_ch9.adb | 112 ++++++++++++++++++++----------------- gcc/ada/rtsfind.ads | 3 - gcc/ada/s-os_lib.adb | 2 +- gcc/ada/s-taprop-linux.adb | 6 +- gcc/ada/s-tposen.adb | 10 ++-- gcc/ada/s-tposen.ads | 18 ++---- gcc/ada/sem_ch6.adb | 9 +++ gcc/ada/sem_prag.adb | 7 --- gcc/ada/sem_util.adb | 21 ++++++- gcc/ada/sem_util.ads | 9 ++- gcc/ada/uintp.adb | 9 ++- gcc/ada/uintp.ads | 10 ++-- 14 files changed, 172 insertions(+), 102 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 74082655728..66cacf11b3b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2017-01-06 Justin Squirek + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): + Remove declaration generation in the case of + System_Tasking_Protected_Objects_Single_Entry being used, + and add a warning message when this is detected to occur. + (Make_Initialize_Protection): Remove reference pass in the case + of System_Tasking_Protected_Objects_Single_Entry. + * rtsfind.ads: Remove RE_Protected_Entry_Queue_Max + * s-tposen.adb (Initialize_Protection_Entry): Remove + Entry_Queue_Max parameter. + * s-tposen.ads: Remove the types use to store the entry queue + maximum. + * sem_prag.adb (Analyze_Pragma): Remove entry families restriction + +2017-01-06 Yannick Moy + + * sem_util.adb, sem_util.ads (Get_Enum_Lit_From_Pos): Strengthen + behavior of function, to also accept out of range positions + and raise Constraint_Error in such case, and to copy sloc from + literal if No_Location passed as location. + * uintp.adb, uintp.ads (UI_To_Int, UI_To_CC): Strengthen behavior + of functions to raise Constraint_Error in case of value not in + appropriate range. + +2017-01-06 Tristan Gingold + + * sem_util.adb, s-taprop-linux.adb (Finalize_TCB): Remove call to + Invalidate_Stack_Cache. + +2017-01-06 Eric Botcazou + + * s-os_lib.adb: Minor fix to the signature of Readlink. + +2017-01-06 Javier Miranda + + * sem_ch6.adb (Conforming_Types): Handle another + confusion between views in a nested instance with an actual + private type whose full view is not in scope. + +2017-01-06 Arnaud Charlet + + * exp_ch5.adb (Expand_N_If_Statement): Obey existing comment and + mark a rewritten if statement as explicit (Comes_From_Source). + 2017-01-06 Gary Dismukes * sem_prag.adb, rtsfind.adb, sem_util.adb: Minor typo fixes. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0127bfbf7f6..4e09e99b8f0 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3209,10 +3209,6 @@ package body Exp_Ch5 is if Present (Condition_Actions (E)) or else Compile_Time_Known_Value (Condition (E)) then - -- Note this is not an implicit if statement, since it is part - -- of an explicit if statement in the source (or of an implicit - -- if statement that has already been tested). - New_If := Make_If_Statement (Sloc (E), Condition => Condition (E), @@ -3243,6 +3239,15 @@ package body Exp_Ch5 is end if; Analyze (New_If); + + -- Note this is not an implicit if statement, since it is part + -- of an explicit if statement in the source (or of an implicit + -- if statement that has already been tested). We set the flag + -- after calling Analyze to avoid generating extra warnings + -- specific to pure if statements, however (see + -- Sem_Ch5.Analyze_If_Statement). + + Set_Comes_From_Source (New_If, Comes_From_Source (N)); return; -- No special processing for that elsif part, move to next diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 54000a0f304..6d31de7670b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -9768,6 +9768,7 @@ package body Exp_Ch9 is -- initialization routine. declare + Max : Uint; Maxs : constant List_Id := New_List; Count : Int; Item : Entity_Id; @@ -9786,69 +9787,80 @@ package body Exp_Ch9 is while Present (Item) loop if Is_Entry (Item) then Count := Count + 1; + Max := Get_Max_Queue_Length (Item); - Append_To (Maxs, - Make_Integer_Literal (Loc, - Intval => Get_Max_Queue_Length (Item))); + -- The package System_Tasking_Protected_Objects_Single_Entry + -- is only used in cases where queue length is 1, so if this + -- package is being used and there is a value supplied for + -- it print an error message and halt compilation. + + if Max /= 0 + and then Corresponding_Runtime_Package (Prot_Typ) = + System_Tasking_Protected_Objects_Single_Entry + then + Error_Msg_N + ("max_queue_length cannot be applied to entries under " + & "the Ravenscar profile", Item); + raise Program_Error; + end if; + + Append_To (Maxs, Make_Integer_Literal (Loc, Intval => Max)); end if; Next_Entity (Item); end loop; - -- Create the declaration of the array object. Generate: + case Corresponding_Runtime_Package (Prot_Typ) is + when System_Tasking_Protected_Objects_Entries => - -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array - -- (1 .. Count) := (..., ...); - -- or - -- Maxs_Id : aliased Protected_Entry_Queue_Max := ; + -- Create the declaration of the array object. Generate: - Maxs_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Prot_Typ), 'B')); + -- Maxs_Id : aliased Protected_Entry_Queue_Max_Array + -- (1 .. Count) := (..., ...); - case Corresponding_Runtime_Package (Prot_Typ) is - when System_Tasking_Protected_Objects_Entries => - Expr := Make_Aggregate (Loc, Maxs); + Maxs_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Prot_Typ), 'B')); - Obj_Def := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Make_Integer_Literal (Loc, 1), - Make_Integer_Literal (Loc, Count))))); + Max_Vals := + Make_Object_Declaration (Loc, + Defining_Identifier => Maxs_Id, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, Count))))), + Expression => Make_Aggregate (Loc, Maxs)); - when System_Tasking_Protected_Objects_Single_Entry => - Expr := Make_Integer_Literal (Loc, Intval (First (Maxs))); + -- A pointer to this array will be placed in the + -- corresponding record by its initialization procedure so + -- this needs to be analyzed here. - Obj_Def := - New_Occurrence_Of - (RTE (RE_Protected_Entry_Queue_Max), Loc); + Insert_After (Current_Node, Max_Vals); + Current_Node := Max_Vals; + Analyze (Max_Vals); - when others => - raise Program_Error; - end case; + Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id); - Max_Vals := - Make_Object_Declaration (Loc, - Defining_Identifier => Maxs_Id, - Aliased_Present => True, - Object_Definition => Obj_Def, - Expression => Expr); + when System_Tasking_Protected_Objects_Single_Entry => - -- A pointer to this array will be placed in the corresponding - -- record by its initialization procedure so this needs to be - -- analyzed here. + -- If this section is entered this means the package + -- System_Tasking_Protected_Objects_Single_Entry is being + -- used and that it correctly has no Max_Queue_Length + -- specified, so fall through and continue normally. - Insert_After (Current_Node, Max_Vals); - Current_Node := Max_Vals; - Analyze (Max_Vals); + null; - Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id); + when others => + raise Program_Error; + end case; end if; end; @@ -14201,7 +14213,9 @@ package body Exp_Ch9 is -- naturals representing the entry queue maximums for each entry -- in the protected type. Zero represents no max. - if Has_Entry then + if Has_Entry + and then Pkg_Id /= System_Tasking_Protected_Objects_Single_Entry + then Append_To (Args, Make_Attribute_Reference (Loc, Prefix => @@ -14212,9 +14226,7 @@ package body Exp_Ch9 is -- Edge cases exist where entry initialization functions are -- called, but no entries exist, so null is appended. - elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry - or else Pkg_Id = System_Tasking_Protected_Objects_Entries - then + elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then Append_To (Args, Make_Null (Loc)); end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1fbca38332a..1f859dffc80 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1717,7 +1717,6 @@ package Rtsfind is RE_Service_Entry, -- Protected_Objects.Single_Entry RE_Exceptional_Complete_Single_Entry_Body, RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry - RE_Protected_Entry_Queue_Max, -- Protected_Objects.Single_Entry RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects @@ -2993,8 +2992,6 @@ package Rtsfind is System_Tasking_Protected_Objects_Single_Entry, RE_Protected_Count_Entry => System_Tasking_Protected_Objects_Single_Entry, - RE_Protected_Entry_Queue_Max => - System_Tasking_Protected_Objects_Single_Entry, RE_Protected_Single_Entry_Caller => System_Tasking_Protected_Objects_Single_Entry, diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 5ac823e6cde..36064e97bd3 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -2060,7 +2060,7 @@ package body System.OS_Lib is function Readlink (Path : System.Address; Buf : System.Address; - Bufsiz : Integer) return Integer; + Bufsiz : size_t) return Integer; pragma Import (C, Readlink, "__gnat_readlink"); function To_Canonical_File_Spec diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 2aad75ebead..85990f6dfb6 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -45,7 +45,6 @@ with System.Tasking.Debug; with System.Interrupt_Management; with System.OS_Constants; with System.OS_Primitives; -with System.Stack_Checking.Operations; with System.Multiprocessors; with System.Soft_Links; @@ -58,7 +57,6 @@ package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; - package SC renames System.Stack_Checking.Operations; use System.Tasking.Debug; use System.Tasking; @@ -1048,8 +1046,6 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); - ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 59d9e912ea1..9bdf7f82238 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -215,11 +215,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is --------------------------------- procedure Initialize_Protection_Entry - (Object : Protection_Entry_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Queue_Max : Protected_Entry_Queue_Max_Access; - Entry_Body : Entry_Body_Access) + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access) is begin Initialize_Protection (Object.Common'Access, Ceiling_Priority); @@ -227,7 +226,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is Object.Compiler_Info := Compiler_Info; Object.Call_In_Progress := null; Object.Entry_Body := Entry_Body; - Object.Entry_Queue_Max := Entry_Queue_Max; Object.Entry_Queue := null; end Initialize_Protection_Entry; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads index bfd82bf0e95..b4ad29a8570 100644 --- a/gcc/ada/s-tposen.ads +++ b/gcc/ada/s-tposen.ads @@ -182,17 +182,11 @@ package System.Tasking.Protected_Objects.Single_Entry is type Protection_Entry_Access is access all Protection_Entry; - type Protected_Entry_Queue_Max is new Natural; - - type Protected_Entry_Queue_Max_Access is - access all Protected_Entry_Queue_Max; - procedure Initialize_Protection_Entry - (Object : Protection_Entry_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Queue_Max : Protected_Entry_Queue_Max_Access; - Entry_Body : Entry_Body_Access); + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access); -- Initialize the Object parameter so that it can be used by the run time -- to keep track of the runtime state of a protected object. @@ -276,10 +270,6 @@ private Entry_Queue : Entry_Call_Link; -- Place to store the waiting entry call (if any) - - Entry_Queue_Max : Protected_Entry_Queue_Max_Access; - -- Access to a natural representing the max value for the single - -- entry's queue length. A value of 0 signifies no max. end record; end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ade6f504a24..3122552e971 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7183,6 +7183,15 @@ package body Sem_Ch6 is return Ctype <= Mode_Conformant or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); + -- Another confusion between views in a nested instance with an + -- actual private type whose full view is not in scope. + + elsif Ekind (Type_2) = E_Private_Subtype + and then In_Instance + and then Etype (Type_2) = Type_1 + then + return True; + -- In Ada 2012, incomplete types (including limited views) can appear -- as actuals in instantiations. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9b773269ee8..c90b45db8c2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17691,13 +17691,6 @@ package body Sem_Prag is Entry_Id := Unique_Defining_Entity (Entry_Decl); - -- Pragma illegally applied to an entry family - - if Ekind (Entry_Id) = E_Entry_Family then - Error_Pragma ("pragma % cannot apply to entry families"); - return; - end if; - -- Otherwise the pragma is associated with an illegal construct else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6055e82d4ed..15d2240648d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8163,6 +8163,7 @@ package body Sem_Util is is Btyp : Entity_Id := Base_Type (T); Lit : Node_Id; + LLoc : Source_Ptr; begin -- In the case where the literal is of type Character, Wide_Character @@ -8173,6 +8174,7 @@ package body Sem_Util is if Is_Standard_Character_Type (T) then Set_Character_Literal_Name (UI_To_CC (Pos)); + return Make_Character_Literal (Loc, Chars => Name_Find, @@ -8190,9 +8192,26 @@ package body Sem_Util is Lit := First_Literal (Btyp); for J in 1 .. UI_To_Int (Pos) loop Next_Literal (Lit); + + -- If Lit is Empty, Pos is not in range, so raise Constraint_Error + -- inside the loop to avoid calling Next_Literal on Empty. + + if No (Lit) then + raise Constraint_Error; + end if; end loop; - return New_Occurrence_Of (Lit, Loc); + -- Create a new node from Lit, with source location provided by Loc + -- if not equal to No_Location, or by copying the source location of + -- Lit otherwise. + + LLoc := Loc; + + if LLoc = No_Location then + LLoc := Sloc (Lit); + end if; + + return New_Occurrence_Of (Lit, LLoc); end if; end Get_Enum_Lit_From_Pos; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f768c0fdb4e..a0f34770bb8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -917,9 +917,12 @@ package Sem_Util is Loc : Source_Ptr) return Node_Id; -- This function returns an identifier denoting the E_Enumeration_Literal -- entity for the specified value from the enumeration type or subtype T. - -- The second argument is the Pos value, which is assumed to be in range. - -- The third argument supplies a source location for constructed nodes - -- returned by this function. + -- The second argument is the Pos value. Constraint_Error is raised if + -- argument Pos is not in range. The third argument supplies a source + -- location for constructed nodes returned by this function. If No_Location + -- is supplied as source location, the location of the returned node is + -- copied from the original source location for the enumeration literal, + -- when available. function Get_Iterable_Type_Primitive (Typ : Entity_Id; diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 948c521b22e..6fdf02fdfe1 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -2229,9 +2229,12 @@ package body Uintp is begin -- Uints of more than one digit could be outside the range for -- Ints. Caller should have checked for this if not certain. - -- Fatal error to attempt to convert from value outside Int'Range. + -- Constraint_Error to attempt to convert from value outside + -- Int'Range. - pragma Assert (UI_Is_In_Int_Range (Input)); + if not UI_Is_In_Int_Range (Input) then + raise Constraint_Error; + end if; -- Otherwise, proceed ahead, we are OK diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index a07fa083039..999fb0f95a6 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -252,12 +252,12 @@ package Uintp is -- Converts Char_Code value to universal integer form function UI_To_Int (Input : Uint) return Int; - -- Converts universal integer value to Int. Fatal error if value is not in - -- appropriate range. + -- Converts universal integer value to Int. Constraint_Error if value is + -- not in appropriate range. function UI_To_CC (Input : Uint) return Char_Code; - -- Converts universal integer value to Char_Code. Fatal error if value is - -- not in Char_Code range. + -- Converts universal integer value to Char_Code. Constraint_Error if value + -- is not in Char_Code range. function Num_Bits (Input : Uint) return Nat; -- Approximate number of binary bits in given universal integer. This -- 2.30.2