OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2015-11-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch9.adb, exp_fixd.adb, exp_util.adb, g-debpoo.adb,
	impunit.adb, scos.ads, sem_ch4.adb, sem_prag.adb,
	s-stchop-vxworks.adb: Minor reformatting.

2015-11-13  Tristan Gingold  <gingold@adacore.com>

	* s-rident.ads (Profile_Info): Enable Pure_Barriers for
	GNAT_Extended_Ravenscar.

2015-11-13  Bob Duff  <duff@adacore.com>

	* sem_ch6.adb (Check_Private_Overriding): Detect the special
	case where the overriding subprogram is overriding a subprogram
	that was declared in the same private part.

From-SVN: r230314
This commit is contained in:
Arnaud Charlet 2015-11-13 14:08:51 +01:00
parent b512289ba2
commit bc38dbb422
12 changed files with 222 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/ChangeLog
View File

@ -1,3 +1,20 @@
2015-11-13 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb, exp_fixd.adb, exp_util.adb, g-debpoo.adb,
impunit.adb, scos.ads, sem_ch4.adb, sem_prag.adb,
s-stchop-vxworks.adb: Minor reformatting.
2015-11-13 Tristan Gingold <gingold@adacore.com>
* s-rident.ads (Profile_Info): Enable Pure_Barriers for
GNAT_Extended_Ravenscar.
2015-11-13 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Detect the special
case where the overriding subprogram is overriding a subprogram
that was declared in the same private part.
2015-11-13 Gary Dismukes <dismukes@adacore.com>
* exp_ch9.adb: Minor reformatting and typo fixes.

41
gcc/ada/exp_ch9.adb
View File

@ -6370,18 +6370,20 @@ package body Exp_Ch9 is
function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
Renamed : Node_Id;
begin
if not Expander_Active then
return Scope (Entity (N)) = Current_Scope;
begin
-- Check for case of _object.all.field (note that the explicit
-- dereference gets inserted by analyze/expand of _object.field).
else
if Expander_Active then
Renamed := Renamed_Object (Entity (N));
return Present (Renamed)
and then Nkind (Renamed) = N_Selected_Component
and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
return
Present (Renamed)
and then Nkind (Renamed) = N_Selected_Component
and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
else
return Scope (Entity (N)) = Current_Scope;
end if;
end Is_Simple_Barrier_Name;
@ -6392,19 +6394,18 @@ package body Exp_Ch9 is
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Identifier
| N_Expanded_Name =>
when N_Expanded_Name |
N_Identifier =>
if No (Entity (N)) then
return Abandon;
end if;
case Ekind (Entity (N)) is
when E_Constant
| E_Discriminant
| E_Named_Integer
| E_Named_Real
| E_Enumeration_Literal =>
when E_Constant |
E_Discriminant |
E_Named_Integer |
E_Named_Real |
E_Enumeration_Literal =>
return OK;
when E_Variable =>
@ -6416,13 +6417,13 @@ package body Exp_Ch9 is
null;
end case;
when N_Integer_Literal
| N_Real_Literal
| N_Character_Literal =>
when N_Integer_Literal |
N_Real_Literal |
N_Character_Literal =>
return OK;
when N_Op_Boolean
| N_Op_Not =>
when N_Op_Boolean |
N_Op_Not =>
if Ekind (Entity (N)) = E_Operator then
return OK;
end if;

35
gcc/ada/exp_fixd.adb
View File

@ -1692,9 +1692,10 @@ package body Exp_Fixd is
-- result cases, and faster.
procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is
Rng_Check : constant Boolean := Do_Range_Check (N);
Expr : constant Node_Id := Expression (N);
Orig_N : constant Node_Id := Original_Node (N);
Result_Type : constant Entity_Id := Etype (N);
Rng_Check : constant Boolean := Do_Range_Check (N);
Small : constant Ureal := Small_Value (Result_Type);
Truncate : Boolean;
@ -1704,27 +1705,31 @@ package body Exp_Fixd is
if Small = Ureal_1 then
Set_Result (N, Expr, Rng_Check, Trunc => True);
-- Normal case where multiply is required
-- Rounding is truncating for decimal fixed point types only,
-- see RM 4.6(29), except if the conversion comes from an attribute
-- reference 'Round (RM 3.5.10 (14)): The attribute is implemented
-- by means of a conversion that must round.
-- Normal case where multiply is required. Rounding is truncating
-- for decimal fixed point types only, see RM 4.6(29), except if the
-- conversion comes from an attribute reference 'Round (RM 3.5.10 (14)):
-- The attribute is implemented by means of a conversion that must
-- round.
else
if Is_Decimal_Fixed_Point_Type (Result_Type) then
Truncate := Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Get_Attribute_Id (Attribute_Name (Original_Node (N)))
/= Attribute_Round;
Truncate :=
Nkind (Orig_N) /= N_Attribute_Reference
or else Get_Attribute_Id
(Attribute_Name (Orig_N)) /= Attribute_Round;
else
Truncate := False;
end if;
Set_Result (N,
Build_Multiply (N,
Fpt_Value (Expr),
Real_Literal (N, Ureal_1 / Small)),
Rng_Check,
Trunc => Truncate);
Set_Result
(N => N,
Expr =>
Build_Multiply
(N => N,
L => Fpt_Value (Expr),
R => Real_Literal (N, Ureal_1 / Small)),
Rchk => Rng_Check,
Trunc => Truncate);
end if;
end Expand_Convert_Float_To_Fixed;

2
gcc/ada/exp_util.adb
View File

@ -1672,8 +1672,8 @@ package body Exp_Util is
function Containing_Package_With_Ext_Axioms
(E : Entity_Id) return Entity_Id
is
Decl : Node_Id;
First_Ax_Parent_Scope : Entity_Id;
Decl : Node_Id;
begin
-- E is the package or generic package which is externally axiomatized

151
gcc/ada/g-debpoo.adb
View File

@ -31,13 +31,13 @@
with GNAT.IO; use GNAT.IO;
with System.Address_Image;
with System.CRTL;
with System.Memory; use System.Memory;
with System.Soft_Links; use System.Soft_Links;
with System.Traceback_Entries;
with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
with GNAT.HTable;
with GNAT.Traceback; use GNAT.Traceback;
@ -226,8 +226,8 @@ package body GNAT.Debug_Pools is
-- data, and does not include the header of that block.
end record;
function Header_Of (Address : System.Address)
return Allocation_Header_Access;
function Header_Of
(Address : System.Address) return Allocation_Header_Access;
pragma Inline (Header_Of);
-- Return the header corresponding to a previously allocated address
@ -294,7 +294,7 @@ package body GNAT.Debug_Pools is
-- up to the first one in the range:
-- Ignored_Frame_Start .. Ignored_Frame_End
procedure Stdout_Put (S : String);
procedure Stdout_Put (S : String);
-- Wrapper for Put that ensures we always write to stdout instead of the
-- current output file defined in GNAT.IO.
@ -306,8 +306,7 @@ package body GNAT.Debug_Pools is
(Output_File : File_Type;
Prefix : String;
Traceback : Traceback_Htable_Elem_Ptr);
-- Output Prefix & Traceback & EOL.
-- Print nothing if Traceback is null.
-- Output Prefix & Traceback & EOL. Print nothing if Traceback is null.
procedure Print_Address (File : File_Type; Addr : Address);
-- Output System.Address without using secondary stack.
@ -479,37 +478,11 @@ package body GNAT.Debug_Pools is
-------------------
procedure Print_Address (File : File_Type; Addr : Address) is
type My_Address is mod Memory_Size;
function To_My_Address is new Ada.Unchecked_Conversion
(System.Address, My_Address);
Address_To_Print : My_Address := To_My_Address (Addr);
type Hexadecimal_Element is range 0 .. 15;
Hexadecimal_Characters : constant array
(Hexadecimal_Element) of Character :=
('0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
pragma Warnings
(Off, "types for unchecked conversion have different sizes");
function To_Hexadecimal_Element is new Ada.Unchecked_Conversion
(My_Address, Hexadecimal_Element);
pragma Warnings
(On, "types for unchecked conversion have different sizes");
Number_Of_Hexadecimal_Characters_In_Address : constant Natural :=
Standard'Address_Size / 4;
type Hexadecimal_Elements_Range is
range 1 .. Number_Of_Hexadecimal_Characters_In_Address;
Hexadecimal_Elements : array (Hexadecimal_Elements_Range) of
Hexadecimal_Element;
begin
for Index in Hexadecimal_Elements_Range loop
Hexadecimal_Elements (Index) :=
To_Hexadecimal_Element (Address_To_Print mod 16);
Address_To_Print := Address_To_Print / 16;
end loop;
Put (File, "0x");
for Index in reverse Hexadecimal_Elements_Range loop
Put (File, Hexadecimal_Characters (Hexadecimal_Elements (Index)));
end loop;
-- Warning: secondary stack cannot be used here. When System.Memory
-- implementation uses Debug_Pool, Print_Address can be called during
-- secondary stack creation for foreign threads.
Put (File, Image_C (Addr));
end Print_Address;
--------------
@ -544,14 +517,20 @@ package body GNAT.Debug_Pools is
begin
if Traceback = null then
declare
Tr : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
Start, Len : Natural;
Len : Natural;
Start : Natural;
Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
begin
Call_Chain (Tr, Len);
Skip_Levels (Depth, Tr, Start, Len,
Ignored_Frame_Start, Ignored_Frame_End);
Print (Tr (Start .. Len));
Call_Chain (Trace, Len);
Skip_Levels
(Depth => Depth,
Trace => Trace,
Start => Start,
Len => Len,
Ignored_Frame_Start => Ignored_Frame_Start,
Ignored_Frame_End => Ignored_Frame_End);
Print (Trace (Start .. Len));
end;
else
@ -613,16 +592,24 @@ package body GNAT.Debug_Pools is
declare
Disable_Exit_Value : constant Boolean := Disable;
Trace : aliased Tracebacks_Array
(1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
Len, Start : Natural;
Elem : Traceback_Htable_Elem_Ptr;
Len : Natural;
Start : Natural;
Trace : aliased Tracebacks_Array
(1 .. Integer (Pool.Stack_Trace_Depth) +
Max_Ignored_Levels);
begin
Disable := True;
Call_Chain (Trace, Len);
Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
Ignored_Frame_Start, Ignored_Frame_End);
Skip_Levels
(Depth => Pool.Stack_Trace_Depth,
Trace => Trace,
Start => Start,
Len => Len,
Ignored_Frame_Start => Ignored_Frame_Start,
Ignored_Frame_End => Ignored_Frame_End);
-- Check if the traceback is already in the table
@ -632,14 +619,16 @@ package body GNAT.Debug_Pools is
-- If not, insert it
if Elem = null then
Elem := new Traceback_Htable_Elem'
(Traceback => new Tracebacks_Array'(Trace (Start .. Len)),
Count => 1,
Kind => Kind,
Total => Byte_Count (Size),
Frees => 0,
Total_Frees => 0,
Next => null);
Elem :=
new Traceback_Htable_Elem'
(Traceback =>
new Tracebacks_Array'(Trace (Start .. Len)),
Count => 1,
Kind => Kind,
Total => Byte_Count (Size),
Frees => 0,
Total_Frees => 0,
Next => null);
Backtrace_Htable.Set (Elem);
else
@ -674,10 +663,10 @@ package body GNAT.Debug_Pools is
Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit;
Max_Validity_Byte_Index : constant :=
Memory_Chunk_Size / Validity_Divisor;
Memory_Chunk_Size / Validity_Divisor;
subtype Validity_Byte_Index is Integer_Address
range 0 .. Max_Validity_Byte_Index - 1;
subtype Validity_Byte_Index is
Integer_Address range 0 .. Max_Validity_Byte_Index - 1;
type Byte is mod 2 ** System.Storage_Unit;
@ -833,15 +822,20 @@ package body GNAT.Debug_Pools is
if Allow_Unhandled_Memory then
if Ptr.Handled = No_Validity_Bits_Part then
Ptr.Handled :=
To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
Memset (Ptr.Handled.all'Address, 0,
size_t (Max_Validity_Byte_Index));
To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
Memset
(A => Ptr.Handled.all'Address,
C => 0,
N => size_t (Max_Validity_Byte_Index));
end if;
Ptr.Handled (Offset / System.Storage_Unit) :=
Ptr.Handled (Offset / System.Storage_Unit) or Bit;
Ptr.Handled (Offset / System.Storage_Unit) or Bit;
end if;
end Set_Handled;
-- Start of processing for Set_Valid
begin
if Ptr = No_Validity_Bits then
@ -851,10 +845,12 @@ package body GNAT.Debug_Pools is
if Value then
Ptr := new Validity_Bits;
Ptr.Valid :=
To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
Validy_Htable.Set (Block_Number, Ptr);
Memset (Ptr.Valid.all'Address, 0,
size_t (Max_Validity_Byte_Index));
Memset
(A => Ptr.Valid.all'Address,
C => 0,
N => size_t (Max_Validity_Byte_Index));
Ptr.Valid (Offset / System.Storage_Unit) := Bit;
Set_Handled;
end if;
@ -870,7 +866,6 @@ package body GNAT.Debug_Pools is
end if;
end if;
end Set_Valid;
end Validity;
--------------
@ -883,7 +878,6 @@ package body GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
pragma Unreferenced (Alignment);
-- Ignored, we always force Storage_Alignment
@ -926,7 +920,7 @@ package body GNAT.Debug_Pools is
-- which is expensive.
if Pool.Logically_Deallocated >
Byte_Count (Pool.Maximum_Logically_Freed_Memory)
Byte_Count (Pool.Maximum_Logically_Freed_Memory)
then
Free_Physically (Pool);
end if;
@ -967,8 +961,9 @@ package body GNAT.Debug_Pools is
-- For the purpose of computing Storage_Address, we just do as if the
-- header was located first, followed by the alignment padding:
Storage_Address := To_Address
(Align (To_Integer (P.all'Address) + Integer_Address (Header_Offset)));
Storage_Address :=
To_Address (Align (To_Integer (P.all'Address) +
Integer_Address (Header_Offset)));
-- Computation is done in Integer_Address, not Storage_Offset, because
-- the range of Storage_Offset may not be large enough.
@ -977,9 +972,13 @@ package body GNAT.Debug_Pools is
pragma Assert (Storage_Address + Size_In_Storage_Elements
<= P.all'Address + P'Length);
Trace := Find_Or_Create_Traceback
(Pool, Alloc, Size_In_Storage_Elements,
Allocate_Label'Address, Code_Address_For_Allocate_End);
Trace :=
Find_Or_Create_Traceback
(Pool => Pool,
Kind => Alloc,
Size => Size_In_Storage_Elements,
Ignored_Frame_Start => Allocate_Label'Address,
Ignored_Frame_End => Code_Address_For_Allocate_End);
pragma Warnings (Off);
-- Turn warning on alignment for convert call off. We know that in fact
@ -1846,7 +1845,7 @@ package body GNAT.Debug_Pools is
Byte_Count'Image (Data.Total) & ") ");
for T in Data.Traceback'Range loop
Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
Put (Image_C (PC_For (Data.Traceback (T))) & ' ');
end loop;
Put_Line ("");
@ -1872,7 +1871,7 @@ package body GNAT.Debug_Pools is
if Header.Alloc_Traceback /= null then
for T in Header.Alloc_Traceback.Traceback'Range loop
Put ("0x" & Address_Image
Put (Image_C
(PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
end loop;
end if;
@ -2010,7 +2009,7 @@ package body GNAT.Debug_Pools is
end;
for J in Max (M).Traceback'Range loop
Put (" 0x" & Address_Image (PC_For (Max (M).Traceback (J))));
Put (Image_C (PC_For (Max (M).Traceback (J))));
end loop;
New_Line;

6
gcc/ada/impunit.adb
View File

@ -649,8 +649,8 @@ package body Impunit is
-- Ada/System/Interfaces are all Ada 95 units
if File = "ada.ads"
or else File = "system.ads"
or else File = "interfac.ads"
or else File = "system.ads"
then
return Ada_95_Unit;
end if;
@ -726,9 +726,9 @@ package body Impunit is
-- Only remaining special possibilities are children of System.RPC and
-- System.Garlic and special files of the form System.Aux...
if File (1 .. 5) = "s-rpc"
if File (1 .. 5) = "s-aux"
or else File (1 .. 5) = "s-gar"
or else File (1 .. 5) = "s-aux"
or else File (1 .. 5) = "s-rpc"
then
return Ada_95_Unit;
end if;

2
gcc/ada/s-rident.ads
View File

@ -543,7 +543,7 @@ package System.Rident is
No_Select_Statements => True,
No_Specific_Termination_Handlers => True,
No_Task_Termination => True,
Simple_Barriers => True,
Pure_Barriers => True,
others => False),
-- Value settings for Ravenscar (same as Restricted)

11
gcc/ada/s-stchop-vxworks.adb
View File

@ -131,15 +131,16 @@ package body System.Stack_Checking.Operations is
Get_Stack_Info (Stack_Info'Access);
if Stack_Grows_Down then
Limit := Stack_Info.Base - Storage_Offset (Stack_Info.Size)
+ Storage_Offset'(16#12_000#);
Limit :=
Stack_Info.Base - Storage_Offset (Stack_Info.Size) +
Storage_Offset'(16#12_000#);
else
Limit := Stack_Info.Base + Storage_Offset (Stack_Info.Size)
- Storage_Offset'(16#12_000#);
Limit :=
Stack_Info.Base + Storage_Offset (Stack_Info.Size) -
Storage_Offset'(16#12_000#);
end if;
Stack_Limit := Limit;
end Set_Stack_Limit_For_Current_Task;
end System.Stack_Checking.Operations;

2
gcc/ada/scos.ads
View File

@ -361,7 +361,7 @@ package SCOs is
end record;
No_Source_Location : constant Source_Location :=
(No_Line_Number, No_Column_Number);
(No_Line_Number, No_Column_Number);
type SCO_Table_Entry is record
From : Source_Location := No_Source_Location;

38
gcc/ada/sem_ch4.adb
View File

@ -2192,9 +2192,9 @@ package body Sem_Ch4 is
Get_Next_Interp (I, It);
end loop;
-- If no valid interpretation has been found, then the type of
-- the ELSE expression does not match any interpretation of
-- the THEN expression.
-- If no valid interpretation has been found, then the type of the
-- ELSE expression does not match any interpretation of the THEN
-- expression.
if Etype (N) = Any_Type then
Error_Msg_N
@ -4665,10 +4665,11 @@ package body Sem_Ch4 is
and then not Is_Entity_Name (Name)
and then Nkind (Name) /= N_Explicit_Dereference
then
Error_Msg_NE ("invalid reference to internal operation "
& "of some object of type&", N, Type_To_Use);
Error_Msg_NE
("invalid reference to internal operation of some object of "
& "type &", N, Type_To_Use);
Set_Entity (Sel, Any_Id);
Set_Etype (Sel, Any_Type);
Set_Etype (Sel, Any_Type);
return;
end if;
@ -4676,9 +4677,7 @@ package body Sem_Ch4 is
-- visible entities are plausible interpretations, check whether
-- there is some other primitive operation with that name.
if Ada_Version >= Ada_2005
and then Is_Tagged_Type (Prefix_Type)
then
if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then
if (Etype (N) = Any_Type
or else not Has_Candidate)
and then Try_Object_Operation (N)
@ -4710,13 +4709,12 @@ package body Sem_Ch4 is
if Has_Candidate
and then Is_Concurrent_Type (Prefix_Type)
and then Nkind (Parent (N)) = N_Procedure_Call_Statement
then
-- Duplicate the call. This is required to avoid problems with
-- the tree transformations performed by Try_Object_Operation.
-- Set properly the parent of the copied call, because it is
-- about to be reanalyzed.
then
declare
Par : constant Node_Id := New_Copy_Tree (Parent (N));
@ -7305,20 +7303,16 @@ package body Sem_Ch4 is
Nam : constant Entity_Id := Current_Entity (Sel);
begin
if Present (Nam)
and then Is_Overloadable (Nam)
then
if Nkind (Parent (Parent (Par)))
= N_Procedure_Call_Statement
if Present (Nam) and then Is_Overloadable (Nam) then
if Nkind (Parent (Parent (Par))) =
N_Procedure_Call_Statement
then
return False;
else
if Ekind (Nam) = E_Function
and then Present (First_Formal (Nam))
then
return Ekind (First_Formal (Nam)) = E_In_Parameter;
end if;
elsif Ekind (Nam) = E_Function
and then Present (First_Formal (Nam))
then
return Ekind (First_Formal (Nam)) = E_In_Parameter;
end if;
end if;
end;

18
gcc/ada/sem_ch6.adb
View File

@ -8759,6 +8759,11 @@ package body Sem_Ch6 is
-- True if S overrides a function in the visible part. The
-- overridden function could be explicitly or implicitly declared.
function Parent_Is_Private return Boolean;
-- This detects the special case where the overriding subprogram
-- is overriding a subprogram that was declared in the same
-- private part. That case is illegal by 3.9.3(10).
function Overrides_Visible_Function
(Partial_View : Entity_Id) return Boolean
is
@ -8797,6 +8802,14 @@ package body Sem_Ch6 is
return False;
end Overrides_Visible_Function;
function Parent_Is_Private return Boolean is
S_Decl : constant Node_Id := Parent (Parent (S));
Overridden_Decl : constant Node_Id :=
Parent (Parent (Overridden_Operation (S)));
begin
return In_Same_List (Overridden_Decl, S_Decl);
end Parent_Is_Private;
-- Start of processing for Check_Private_Overriding
begin
@ -8808,10 +8821,11 @@ package body Sem_Ch6 is
if Is_Abstract_Type (T)
and then Is_Abstract_Subprogram (S)
and then (not Is_Overriding
or else not Is_Abstract_Subprogram (E))
or else not Is_Abstract_Subprogram (E)
or else Parent_Is_Private)
then
Error_Msg_N ("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S);
& "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function then
declare

81
gcc/ada/sem_prag.adb
View File

@ -9660,11 +9660,6 @@ package body Sem_Prag is
-- No_Dependence => System.Multiprocessors.Dispatching_Domains
procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
Prefix_Entity : Entity_Id;
Selector_Entity : Entity_Id;
Prefix_Node : Node_Id;
Node : Node_Id;
procedure Set_Error_Msg_To_Profile_Name;
-- Set Error_Msg_String and Error_Msg_Strlen to the name of the
-- profile.
@ -9674,16 +9669,26 @@ package body Sem_Prag is
-----------------------------------
procedure Set_Error_Msg_To_Profile_Name is
Pragma_Args : constant List_Id :=
Pragma_Argument_Associations (N);
Profile_Name : constant Node_Id :=
Get_Pragma_Arg (First (Pragma_Args));
Prof_Nam : constant Node_Id :=
Get_Pragma_Arg
(First (Pragma_Argument_Associations (N)));
begin
Get_Name_String (Chars (Profile_Name));
Adjust_Name_Case (Sloc (Profile_Name));
Get_Name_String (Chars (Prof_Nam));
Adjust_Name_Case (Sloc (Prof_Nam));
Error_Msg_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
end Set_Error_Msg_To_Profile_Name;
-- Local variables
Nod : Node_Id;
Pref : Node_Id;
Pref_Id : Node_Id;
Sel_Id : Node_Id;
-- Start of processing for Set_Ravenscar_Profile
begin
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
@ -9747,52 +9752,56 @@ package body Sem_Prag is
-- No_Dependence => Ada.Execution_Time.Group_Budget
-- No_Dependence => Ada.Execution_Time.Timers
-- ??? The use of Name_Buffer here is suspicious. The names should
-- be registered in snames.ads-tmpl and used to build the qualified
-- names of units.
if Ada_Version >= Ada_2005 then
Name_Buffer (1 .. 3) := "ada";
Name_Len := 3;
Prefix_Entity := Make_Identifier (Loc, Name_Find);
Pref_Id := Make_Identifier (Loc, Name_Find);
Name_Buffer (1 .. 14) := "execution_time";
Name_Len := 14;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Sel_Id := Make_Identifier (Loc, Name_Find);
Prefix_Node :=
Pref :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Entity,
Selector_Name => Selector_Entity);
Prefix => Pref_Id,
Selector_Name => Sel_Id);
Name_Buffer (1 .. 13) := "group_budgets";
Name_Len := 13;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Sel_Id := Make_Identifier (Loc, Name_Find);
Node :=
Nod :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Prefix => Pref,
Selector_Name => Sel_Id);
Set_Restriction_No_Dependence
(Unit => Node,
(Unit => Nod,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
Name_Buffer (1 .. 6) := "timers";
Name_Len := 6;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Sel_Id := Make_Identifier (Loc, Name_Find);
Node :=
Nod :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Prefix => Pref,
Selector_Name => Sel_Id);
Set_Restriction_No_Dependence
(Unit => Node,
(Unit => Nod,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
end if;
@ -9805,32 +9814,32 @@ package body Sem_Prag is
Name_Buffer (1 .. 6) := "system";
Name_Len := 6;
Prefix_Entity := Make_Identifier (Loc, Name_Find);
Pref_Id := Make_Identifier (Loc, Name_Find);
Name_Buffer (1 .. 15) := "multiprocessors";
Name_Len := 15;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Sel_Id := Make_Identifier (Loc, Name_Find);
Prefix_Node :=
Pref :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Entity,
Selector_Name => Selector_Entity);
Prefix => Pref_Id,
Selector_Name => Sel_Id);
Name_Buffer (1 .. 19) := "dispatching_domains";
Name_Len := 19;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Sel_Id := Make_Identifier (Loc, Name_Find);
Node :=
Nod :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Prefix => Pref,
Selector_Name => Sel_Id);
Set_Restriction_No_Dependence
(Unit => Node,
(Unit => Nod,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
end if;