+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.
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),
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
-- initialization routine.
declare
+ Max : Uint;
Maxs : constant List_Id := New_List;
Count : Int;
Item : Entity_Id;
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 := <value>;
+ -- 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;
-- 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 =>
-- 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;
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
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,
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
-- --
-- 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- --
with System.Interrupt_Management;
with System.OS_Constants;
with System.OS_Primitives;
-with System.Stack_Checking.Operations;
with System.Multiprocessors;
with System.Soft_Links;
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;
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;
---------------------------------
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);
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;
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.
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;
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.
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
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
if Is_Standard_Character_Type (T) then
Set_Character_Literal_Name (UI_To_CC (Pos));
+
return
Make_Character_Literal (Loc,
Chars => Name_Find,
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;
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;
-- --
-- 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- --
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
-- --
-- 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- --
-- 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
projects / gcc.git / commitdiff