git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2017-01-06  Justin Squirek  <squirek@adacore.com>

	* 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  <moy@adacore.com>

	* 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  <gingold@adacore.com>

	* sem_util.adb, s-taprop-linux.adb (Finalize_TCB): Remove call to
	Invalidate_Stack_Cache.

2017-01-06  Eric Botcazou  <ebotcazou@adacore.com>

	* s-os_lib.adb: Minor fix to the signature of Readlink.

2017-01-06  Javier Miranda  <miranda@adacore.com>

	* 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  <charlet@adacore.com>

	* exp_ch5.adb (Expand_N_If_Statement): Obey existing comment and
	mark a rewritten if statement as explicit (Comes_From_Source).

From-SVN: r244128
This commit is contained in:
Arnaud Charlet 2017-01-06 11:43:33 +01:00
parent ea1135b83e
commit 7727a9c182
14 changed files with 173 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -1,3 +1,48 @@
2017-01-06 Justin Squirek <squirek@adacore.com>
* 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 <moy@adacore.com>
* 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 <gingold@adacore.com>
* sem_util.adb, s-taprop-linux.adb (Finalize_TCB): Remove call to
Invalidate_Stack_Cache.
2017-01-06 Eric Botcazou <ebotcazou@adacore.com>
* s-os_lib.adb: Minor fix to the signature of Readlink.
2017-01-06 Javier Miranda <miranda@adacore.com>
* 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 <charlet@adacore.com>
* 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 <dismukes@adacore.com>
* sem_prag.adb, rtsfind.adb, sem_util.adb: Minor typo fixes.

13
gcc/ada/exp_ch5.adb
View File

@ -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

114
gcc/ada/exp_ch9.adb
View File

@ -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:
-- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
-- (1 .. Count) := (..., ...);
-- or
-- Maxs_Id : aliased Protected_Entry_Queue_Max := <value>;
Maxs_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Prot_Typ), 'B'));
case Corresponding_Runtime_Package (Prot_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Expr := Make_Aggregate (Loc, Maxs);
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)))));
-- Create the declaration of the array object. Generate:
-- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
-- (1 .. Count) := (..., ...);
Maxs_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Prot_Typ), 'B'));
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));
-- A pointer to this array will be placed in the
-- corresponding record by its initialization procedure so
-- this needs to be analyzed here.
Insert_After (Current_Node, Max_Vals);
Current_Node := Max_Vals;
Analyze (Max_Vals);
Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
when System_Tasking_Protected_Objects_Single_Entry =>
Expr := Make_Integer_Literal (Loc, Intval (First (Maxs)));
Obj_Def :=
New_Occurrence_Of
(RTE (RE_Protected_Entry_Queue_Max), Loc);
-- 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.
null;
when others =>
raise Program_Error;
end case;
Max_Vals :=
Make_Object_Declaration (Loc,
Defining_Identifier => Maxs_Id,
Aliased_Present => True,
Object_Definition => Obj_Def,
Expression => Expr);
-- A pointer to this array will be placed in the corresponding
-- record by its initialization procedure so this needs to be
-- analyzed here.
Insert_After (Current_Node, Max_Vals);
Current_Node := Max_Vals;
Analyze (Max_Vals);
Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
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;

3
gcc/ada/rtsfind.ads
View File

@ -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,

2
gcc/ada/s-os_lib.adb
View File

@ -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

6
gcc/ada/s-taprop-linux.adb
View File

@ -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;

10
gcc/ada/s-tposen.adb
View File

@ -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;

18
gcc/ada/s-tposen.ads
View File

@ -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;

9
gcc/ada/sem_ch6.adb
View File

@ -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.

7
gcc/ada/sem_prag.adb
View File

@ -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

21
gcc/ada/sem_util.adb
View File

@ -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;

9
gcc/ada/sem_util.ads
View File

@ -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;

9
gcc/ada/uintp.adb
View File

@ -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

10
gcc/ada/uintp.ads
View File

@ -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