[multiple changes]
2012-07-09 Thomas Quinot <quinot@adacore.com> * einfo.adb (Set_Reverse_Storage_Order): Update assertion, flag is now valid for array types as well. 2012-07-09 Tristan Gingold <gingold@adacore.com> * tracebak.c: Implement __gnat_backtrace for Win64 SEH. 2012-07-09 Robert Dewar <dewar@adacore.com> * einfo.ads: Minor reformatting. 2012-07-09 Javier Miranda <miranda@adacore.com> * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Handle as renaming_as_body renamings of predefined dispatching equality and unequality operators. 2012-07-09 Robert Dewar <dewar@adacore.com> * rident.ads: Do not instantiate r-ident.ads, this is now an independent unit. 2012-07-09 Javier Miranda <miranda@adacore.com> * exp_disp.adb (Write_DT): Avoid runtime crash of this debugging routine. * sem_disp.adb (Find_Dispatching_Time): Protect this routine against partially decorated entities. 2012-07-09 Ed Schonberg <schonberg@adacore.com> * sem_ch13.adb (Check_Size): Reject a size clause that specifies a value greater than Int'Last for a scalar type. 2012-07-09 Vincent Pucci <pucci@adacore.com> * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support atomic operation moved to the protected body case. No non-elementary out parameter moved to the protected declaration case. Functions have only one lock-free restriction. (Analyze_Protected_Type_Declaration): Issue a warning when Priority given with Lock_Free. 2012-07-09 Vincent Pucci <pucci@adacore.com> * sem_dim.adb: Grammar of aspect Dimension fixed. 2012-07-09 Vincent Pucci <pucci@adacore.com> * freeze.adb (Freeze_Record_Type): Code reorg in order to avoid pushing and popping the scope stack whenever a delayed aspect occurs. 2012-07-09 Gary Dismukes <dismukes@adacore.com> * s-os_lib.ads: Remove pragma Elaborate_Body, as this is now unnecessary due to recently added pragma Preelaborate. 2012-07-09 Jose Ruiz <ruiz@adacore.com> * s-taprop-mingw.adb (Set_Priority): Remove the code that was previously in place to reorder the ready queue when a task drops its priority due to the loss of inherited priority. From-SVN: r189377
This commit is contained in:
parent
a2c1791d89
commit
22a83cea15
|
@ -1,3 +1,68 @@
|
||||||
|
2012-07-09 Thomas Quinot <quinot@adacore.com>
|
||||||
|
|
||||||
|
* einfo.adb (Set_Reverse_Storage_Order): Update assertion,
|
||||||
|
flag is now valid for array types as well.
|
||||||
|
|
||||||
|
2012-07-09 Tristan Gingold <gingold@adacore.com>
|
||||||
|
|
||||||
|
* tracebak.c: Implement __gnat_backtrace for Win64 SEH.
|
||||||
|
|
||||||
|
2012-07-09 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* einfo.ads: Minor reformatting.
|
||||||
|
|
||||||
|
2012-07-09 Javier Miranda <miranda@adacore.com>
|
||||||
|
|
||||||
|
* exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Handle as
|
||||||
|
renaming_as_body renamings of predefined dispatching equality
|
||||||
|
and unequality operators.
|
||||||
|
|
||||||
|
2012-07-09 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* rident.ads: Do not instantiate r-ident.ads, this is now an
|
||||||
|
independent unit.
|
||||||
|
|
||||||
|
2012-07-09 Javier Miranda <miranda@adacore.com>
|
||||||
|
|
||||||
|
* exp_disp.adb (Write_DT): Avoid runtime crash of this debugging
|
||||||
|
routine.
|
||||||
|
* sem_disp.adb (Find_Dispatching_Time): Protect this routine
|
||||||
|
against partially decorated entities.
|
||||||
|
|
||||||
|
2012-07-09 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch13.adb (Check_Size): Reject a size clause that specifies
|
||||||
|
a value greater than Int'Last for a scalar type.
|
||||||
|
|
||||||
|
2012-07-09 Vincent Pucci <pucci@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch9.adb (Allows_Lock_Free_Implementation): type must support
|
||||||
|
atomic operation moved to the protected body case. No non-elementary
|
||||||
|
out parameter moved to the protected declaration case. Functions have
|
||||||
|
only one lock-free restriction.
|
||||||
|
(Analyze_Protected_Type_Declaration): Issue a warning when
|
||||||
|
Priority given with Lock_Free.
|
||||||
|
|
||||||
|
2012-07-09 Vincent Pucci <pucci@adacore.com>
|
||||||
|
|
||||||
|
* sem_dim.adb: Grammar of aspect Dimension fixed.
|
||||||
|
|
||||||
|
2012-07-09 Vincent Pucci <pucci@adacore.com>
|
||||||
|
|
||||||
|
* freeze.adb (Freeze_Record_Type): Code reorg in order to avoid
|
||||||
|
pushing and popping the scope stack whenever a delayed aspect occurs.
|
||||||
|
|
||||||
|
2012-07-09 Gary Dismukes <dismukes@adacore.com>
|
||||||
|
|
||||||
|
* s-os_lib.ads: Remove pragma Elaborate_Body, as
|
||||||
|
this is now unnecessary due to recently added pragma Preelaborate.
|
||||||
|
|
||||||
|
2012-07-09 Jose Ruiz <ruiz@adacore.com>
|
||||||
|
|
||||||
|
* s-taprop-mingw.adb (Set_Priority): Remove the code that was
|
||||||
|
previously in place to reorder the ready queue when a task drops
|
||||||
|
its priority due to the loss of inherited priority.
|
||||||
|
|
||||||
2012-07-09 Robert Dewar <dewar@adacore.com>
|
2012-07-09 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb,
|
* layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb,
|
||||||
|
|
|
@ -5163,7 +5163,8 @@ package body Einfo is
|
||||||
procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is
|
procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is
|
||||||
begin
|
begin
|
||||||
pragma Assert
|
pragma Assert
|
||||||
(Is_Record_Type (Id) and then Is_Base_Type (Id));
|
(Is_Base_Type (Id)
|
||||||
|
and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
|
||||||
Set_Flag93 (Id, V);
|
Set_Flag93 (Id, V);
|
||||||
end Set_Reverse_Storage_Order;
|
end Set_Reverse_Storage_Order;
|
||||||
|
|
||||||
|
|
|
@ -5021,6 +5021,7 @@ package Einfo is
|
||||||
-- Has_Component_Size_Clause (Flag68) (base type only)
|
-- Has_Component_Size_Clause (Flag68) (base type only)
|
||||||
-- Has_Pragma_Pack (Flag121) (impl base type only)
|
-- Has_Pragma_Pack (Flag121) (impl base type only)
|
||||||
-- Is_Constrained (Flag12)
|
-- Is_Constrained (Flag12)
|
||||||
|
-- Reverse_Storage_Order (Flag93) (base type only)
|
||||||
-- Next_Index (synth)
|
-- Next_Index (synth)
|
||||||
-- Number_Dimensions (synth)
|
-- Number_Dimensions (synth)
|
||||||
-- (plus type attributes)
|
-- (plus type attributes)
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -239,6 +239,44 @@ package body Exp_Ch8 is
|
||||||
----------------------------------------------
|
----------------------------------------------
|
||||||
|
|
||||||
procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
|
procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
|
||||||
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
|
Id : constant Entity_Id := Defining_Entity (N);
|
||||||
|
|
||||||
|
function Build_Body_For_Renaming return Node_Id;
|
||||||
|
-- Build and return the body for the renaming declaration of an
|
||||||
|
-- equality or unequality operator.
|
||||||
|
|
||||||
|
function Build_Body_For_Renaming return Node_Id is
|
||||||
|
Body_Id : Entity_Id;
|
||||||
|
Decl : Node_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Set_Alias (Id, Empty);
|
||||||
|
Set_Has_Completion (Id, False);
|
||||||
|
Rewrite (N,
|
||||||
|
Make_Subprogram_Declaration (Sloc (N),
|
||||||
|
Specification => Specification (N)));
|
||||||
|
Set_Has_Delayed_Freeze (Id);
|
||||||
|
|
||||||
|
Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
|
||||||
|
Set_Debug_Info_Needed (Body_Id);
|
||||||
|
|
||||||
|
Decl :=
|
||||||
|
Make_Subprogram_Body (Loc,
|
||||||
|
Specification =>
|
||||||
|
Make_Function_Specification (Loc,
|
||||||
|
Defining_Unit_Name => Body_Id,
|
||||||
|
Parameter_Specifications => Copy_Parameter_List (Id),
|
||||||
|
Result_Definition =>
|
||||||
|
New_Occurrence_Of (Standard_Boolean, Loc)),
|
||||||
|
Declarations => Empty_List,
|
||||||
|
Handled_Statement_Sequence => Empty);
|
||||||
|
|
||||||
|
return Decl;
|
||||||
|
end Build_Body_For_Renaming;
|
||||||
|
|
||||||
|
-- Local variable
|
||||||
|
|
||||||
Nam : constant Node_Id := Name (N);
|
Nam : constant Node_Id := Name (N);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -259,25 +297,26 @@ package body Exp_Ch8 is
|
||||||
Force_Evaluation (Prefix (Nam));
|
Force_Evaluation (Prefix (Nam));
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Check whether this is a renaming of a predefined equality on an
|
-- Handle cases where we build a body for a renamed equality
|
||||||
-- untagged record type (AI05-0123).
|
|
||||||
|
|
||||||
if Is_Entity_Name (Nam)
|
if Is_Entity_Name (Nam)
|
||||||
and then Chars (Entity (Nam)) = Name_Op_Eq
|
and then (Chars (Entity (Nam)) = Name_Op_Ne
|
||||||
|
or else Chars (Entity (Nam)) = Name_Op_Eq)
|
||||||
and then Scope (Entity (Nam)) = Standard_Standard
|
and then Scope (Entity (Nam)) = Standard_Standard
|
||||||
and then Ada_Version >= Ada_2012
|
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Loc : constant Source_Ptr := Sloc (N);
|
Left : constant Entity_Id := First_Formal (Id);
|
||||||
Id : constant Entity_Id := Defining_Entity (N);
|
Right : constant Entity_Id := Next_Formal (Left);
|
||||||
Typ : constant Entity_Id := Etype (First_Formal (Id));
|
Typ : constant Entity_Id := Etype (Left);
|
||||||
|
Decl : Node_Id;
|
||||||
Decl : Node_Id;
|
|
||||||
Body_Id : constant Entity_Id :=
|
|
||||||
Make_Defining_Identifier (Sloc (N), Chars (Id));
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Is_Record_Type (Typ)
|
-- Check whether this is a renaming of a predefined equality on an
|
||||||
|
-- untagged record type (AI05-0123).
|
||||||
|
|
||||||
|
if Ada_Version >= Ada_2012
|
||||||
|
and then Chars (Entity (Nam)) = Name_Op_Eq
|
||||||
|
and then Is_Record_Type (Typ)
|
||||||
and then not Is_Tagged_Type (Typ)
|
and then not Is_Tagged_Type (Typ)
|
||||||
and then not Is_Frozen (Typ)
|
and then not Is_Frozen (Typ)
|
||||||
then
|
then
|
||||||
|
@ -288,23 +327,7 @@ package body Exp_Ch8 is
|
||||||
-- declaration, and the body is inserted at the end of the
|
-- declaration, and the body is inserted at the end of the
|
||||||
-- current declaration list to prevent premature freezing.
|
-- current declaration list to prevent premature freezing.
|
||||||
|
|
||||||
Set_Alias (Id, Empty);
|
Decl := Build_Body_For_Renaming;
|
||||||
Set_Has_Completion (Id, False);
|
|
||||||
Rewrite (N,
|
|
||||||
Make_Subprogram_Declaration (Sloc (N),
|
|
||||||
Specification => Specification (N)));
|
|
||||||
Set_Has_Delayed_Freeze (Id);
|
|
||||||
|
|
||||||
Decl := Make_Subprogram_Body (Loc,
|
|
||||||
Specification =>
|
|
||||||
Make_Function_Specification (Loc,
|
|
||||||
Defining_Unit_Name => Body_Id,
|
|
||||||
Parameter_Specifications =>
|
|
||||||
Copy_Parameter_List (Id),
|
|
||||||
Result_Definition =>
|
|
||||||
New_Occurrence_Of (Standard_Boolean, Loc)),
|
|
||||||
Declarations => Empty_List,
|
|
||||||
Handled_Statement_Sequence => Empty);
|
|
||||||
|
|
||||||
Set_Handled_Statement_Sequence (Decl,
|
Set_Handled_Statement_Sequence (Decl,
|
||||||
Make_Handled_Sequence_Of_Statements (Loc,
|
Make_Handled_Sequence_Of_Statements (Loc,
|
||||||
|
@ -322,7 +345,63 @@ package body Exp_Ch8 is
|
||||||
Bodies => Declarations (Decl))))));
|
Bodies => Declarations (Decl))))));
|
||||||
|
|
||||||
Append (Decl, List_Containing (N));
|
Append (Decl, List_Containing (N));
|
||||||
Set_Debug_Info_Needed (Body_Id);
|
|
||||||
|
-- Handle renamings of predefined dispatching equality operators.
|
||||||
|
-- When we analyze a renaming of the equality operator of a tagged
|
||||||
|
-- type, the predefined dispatching primitives are not available
|
||||||
|
-- (since they are added by the expander when the tagged type is
|
||||||
|
-- frozen) and hence they are left decorated as renamings of the
|
||||||
|
-- standard non-dispatching operators. Here we generate a body
|
||||||
|
-- for such renamings which invokes the predefined dispatching
|
||||||
|
-- equality operator.
|
||||||
|
|
||||||
|
-- Example:
|
||||||
|
|
||||||
|
-- type T is tagged null record;
|
||||||
|
-- function Eq (X, Y : T1) return Boolean renames "=";
|
||||||
|
-- function Neq (X, Y : T1) return Boolean renames "/=";
|
||||||
|
|
||||||
|
elsif Is_Record_Type (Typ)
|
||||||
|
and then Is_Tagged_Type (Typ)
|
||||||
|
and then Is_Dispatching_Operation (Id)
|
||||||
|
and then not Is_Dispatching_Operation (Entity (Nam))
|
||||||
|
then
|
||||||
|
pragma Assert (not Is_Frozen (Typ));
|
||||||
|
|
||||||
|
Decl := Build_Body_For_Renaming;
|
||||||
|
|
||||||
|
-- Clean decoration of intrinsic subprogram
|
||||||
|
|
||||||
|
Set_Is_Intrinsic_Subprogram (Id, False);
|
||||||
|
Set_Convention (Id, Convention_Ada);
|
||||||
|
|
||||||
|
if Chars (Entity (Nam)) = Name_Op_Ne then
|
||||||
|
Set_Handled_Statement_Sequence (Decl,
|
||||||
|
Make_Handled_Sequence_Of_Statements (Loc,
|
||||||
|
Statements => New_List (
|
||||||
|
Make_Simple_Return_Statement (Loc,
|
||||||
|
Expression =>
|
||||||
|
Make_Op_Not (Loc,
|
||||||
|
Make_Op_Eq (Loc,
|
||||||
|
Left_Opnd =>
|
||||||
|
New_Reference_To (Left, Loc),
|
||||||
|
Right_Opnd =>
|
||||||
|
New_Reference_To (Right, Loc)))))));
|
||||||
|
|
||||||
|
else pragma Assert (Chars (Entity (Nam)) = Name_Op_Eq);
|
||||||
|
Set_Handled_Statement_Sequence (Decl,
|
||||||
|
Make_Handled_Sequence_Of_Statements (Loc,
|
||||||
|
Statements => New_List (
|
||||||
|
Make_Simple_Return_Statement (Loc,
|
||||||
|
Expression =>
|
||||||
|
Make_Op_Eq (Loc,
|
||||||
|
Left_Opnd =>
|
||||||
|
New_Reference_To (Left, Loc),
|
||||||
|
Right_Opnd =>
|
||||||
|
New_Reference_To (Right, Loc))))));
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Append (Decl, List_Containing (N));
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -5777,7 +5777,7 @@ package body Exp_Disp is
|
||||||
Prefix => New_Reference_To (TSD, Loc),
|
Prefix => New_Reference_To (TSD, Loc),
|
||||||
Attribute_Name => Name_Address));
|
Attribute_Name => Name_Address));
|
||||||
|
|
||||||
-- Stage 2: Initialize the table of primitive operations
|
-- Stage 2: Initialize the table of user-defined primitive operations
|
||||||
|
|
||||||
Prim_Ops_Aggr_List := New_List;
|
Prim_Ops_Aggr_List := New_List;
|
||||||
|
|
||||||
|
@ -8857,7 +8857,8 @@ package body Exp_Disp is
|
||||||
-- If the DTC_Entity attribute is already set we can also output
|
-- If the DTC_Entity attribute is already set we can also output
|
||||||
-- the name of the interface covered by this primitive (if any).
|
-- the name of the interface covered by this primitive (if any).
|
||||||
|
|
||||||
if Present (DTC_Entity (Alias (Prim)))
|
if Ekind_In (Alias (Prim), E_Function, E_Procedure)
|
||||||
|
and then Present (DTC_Entity (Alias (Prim)))
|
||||||
and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
|
and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
|
||||||
then
|
then
|
||||||
Write_Str (" from interface ");
|
Write_Str (" from interface ");
|
||||||
|
|
|
@ -1814,6 +1814,11 @@ package body Freeze is
|
||||||
Junk : Boolean;
|
Junk : Boolean;
|
||||||
pragma Warnings (Off, Junk);
|
pragma Warnings (Off, Junk);
|
||||||
|
|
||||||
|
Rec_Pushed : Boolean := False;
|
||||||
|
-- Set True if the record type scope Rec has been pushed on the scope
|
||||||
|
-- stack. Needed for the analysis of delayed aspects specified to the
|
||||||
|
-- components of Rec.
|
||||||
|
|
||||||
Unplaced_Component : Boolean := False;
|
Unplaced_Component : Boolean := False;
|
||||||
-- Set True if we find at least one component with no component
|
-- Set True if we find at least one component with no component
|
||||||
-- clause (used to warn about useless Pack pragmas).
|
-- clause (used to warn about useless Pack pragmas).
|
||||||
|
@ -1901,39 +1906,53 @@ package body Freeze is
|
||||||
-- Start of processing for Freeze_Record_Type
|
-- Start of processing for Freeze_Record_Type
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
-- Deal with delayed aspect specifications for components. The
|
||||||
|
-- analysis of the aspect is required to be delayed to the freeze
|
||||||
|
-- point, thus we analyze the pragma or attribute definition clause
|
||||||
|
-- in the tree at this point. We also analyze the aspect
|
||||||
|
-- specification node at the freeze point when the aspect doesn't
|
||||||
|
-- correspond to pragma/attribute definition clause.
|
||||||
|
|
||||||
|
Comp := First_Entity (Rec);
|
||||||
|
while Present (Comp) loop
|
||||||
|
if Ekind (Comp) = E_Component
|
||||||
|
and then Has_Delayed_Aspects (Comp)
|
||||||
|
then
|
||||||
|
if not Rec_Pushed then
|
||||||
|
Push_Scope (Rec);
|
||||||
|
Rec_Pushed := True;
|
||||||
|
|
||||||
|
-- The visibility to the discriminants must be restored in
|
||||||
|
-- order to properly analyze the aspects.
|
||||||
|
|
||||||
|
if Has_Discriminants (Rec) then
|
||||||
|
Install_Discriminants (Rec);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Analyze_Aspects_At_Freeze_Point (Comp);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next_Entity (Comp);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- Pop the scope if Rec scope has been pushed on the scope stack
|
||||||
|
-- during the delayed aspect analysis process.
|
||||||
|
|
||||||
|
if Rec_Pushed then
|
||||||
|
if Has_Discriminants (Rec) then
|
||||||
|
Uninstall_Discriminants (Rec);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Pop_Scope;
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Freeze components and embedded subtypes
|
-- Freeze components and embedded subtypes
|
||||||
|
|
||||||
Comp := First_Entity (Rec);
|
Comp := First_Entity (Rec);
|
||||||
Prev := Empty;
|
Prev := Empty;
|
||||||
while Present (Comp) loop
|
while Present (Comp) loop
|
||||||
|
|
||||||
-- Deal with delayed aspect specifications for components. The
|
|
||||||
-- analysis of the aspect is required to be delayed to the freeze
|
|
||||||
-- point, thus we analyze the pragma or attribute definition
|
|
||||||
-- clause in the tree at this point. We also analyze the aspect
|
|
||||||
-- specification node at the freeze point when the aspect doesn't
|
|
||||||
-- correspond to pragma/attribute definition clause.
|
|
||||||
|
|
||||||
if Ekind (Comp) = E_Component
|
|
||||||
and then Has_Delayed_Aspects (Comp)
|
|
||||||
then
|
|
||||||
Push_Scope (Rec);
|
|
||||||
|
|
||||||
-- The visibility to the discriminants must be restored in
|
|
||||||
-- order to properly analyze the aspects.
|
|
||||||
|
|
||||||
if Has_Discriminants (Rec) then
|
|
||||||
Install_Discriminants (Rec);
|
|
||||||
Analyze_Aspects_At_Freeze_Point (Comp);
|
|
||||||
Uninstall_Discriminants (Rec);
|
|
||||||
|
|
||||||
else
|
|
||||||
Analyze_Aspects_At_Freeze_Point (Comp);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Pop_Scope;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Handle the component and discriminant case
|
-- Handle the component and discriminant case
|
||||||
|
|
||||||
if Ekind (Comp) = E_Component
|
if Ekind (Comp) = E_Component
|
||||||
|
|
|
@ -768,7 +768,7 @@ package body Restrict is
|
||||||
----------------------------------
|
----------------------------------
|
||||||
|
|
||||||
-- Note: body of this function must be coordinated with list of
|
-- Note: body of this function must be coordinated with list of
|
||||||
-- renaming declarations in System.Rident.
|
-- renaming declarations in Rident.
|
||||||
|
|
||||||
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
|
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
|
||||||
is
|
is
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -332,10 +332,10 @@ package Restrict is
|
||||||
-- exception propagation is activated.
|
-- exception propagation is activated.
|
||||||
|
|
||||||
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
|
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
|
||||||
-- Id is a node whose Chars field contains the name of a restriction.
|
-- Id is a node whose Chars field contains the name of a restriction. If it
|
||||||
-- If it is one of synonyms that we allow for historical purposes (for
|
-- is one of synonyms that we allow for historical purposes (for list see
|
||||||
-- list see System.Rident), then the proper official name is returned.
|
-- Rident), then the proper official name is returned. Otherwise the Chars
|
||||||
-- Otherwise the Chars field of the argument is returned unchanged.
|
-- field of the argument is returned unchanged.
|
||||||
|
|
||||||
function Restriction_Active (R : All_Restrictions) return Boolean;
|
function Restriction_Active (R : All_Restrictions) return Boolean;
|
||||||
pragma Inline (Restriction_Active);
|
pragma Inline (Restriction_Active);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2009 Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -34,16 +34,416 @@
|
||||||
-- it can be used by the binder without dragging in unneeded compiler
|
-- it can be used by the binder without dragging in unneeded compiler
|
||||||
-- packages.
|
-- packages.
|
||||||
|
|
||||||
-- Note: the actual definitions of the types are in package System.Rident,
|
package Rident is
|
||||||
-- and this package is merely an instantiation of that package. The point
|
|
||||||
-- of this level of generic indirection is to allow the compile time use
|
|
||||||
-- to have the image tables available (this package is not compiled with
|
|
||||||
-- Discard_Names), while at run-time we do not want those image tables.
|
|
||||||
|
|
||||||
-- Rather than have clients instantiate System.Rident directly, we have the
|
-- The following enumeration type defines the set of restriction
|
||||||
-- single instantiation here at the library level, which means that we only
|
-- identifiers that are implemented in GNAT.
|
||||||
-- have one copy of the image tables
|
|
||||||
|
|
||||||
with System.Rident;
|
-- To add a new restriction identifier, add an entry with the name to be
|
||||||
|
-- used in the pragma, and add calls to the Restrict.Check_Restriction
|
||||||
|
-- routine as appropriate.
|
||||||
|
|
||||||
package Rident is new System.Rident;
|
type Restriction_Id is
|
||||||
|
|
||||||
|
-- The following cases are checked for consistency in the binder. The
|
||||||
|
-- binder will check that every unit either has the restriction set, or
|
||||||
|
-- does not violate the restriction.
|
||||||
|
|
||||||
|
(Simple_Barriers, -- GNAT (Ravenscar)
|
||||||
|
No_Abort_Statements, -- (RM D.7(5), H.4(3))
|
||||||
|
No_Access_Subprograms, -- (RM H.4(17))
|
||||||
|
No_Allocators, -- (RM H.4(7))
|
||||||
|
No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2))
|
||||||
|
No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1))
|
||||||
|
No_Asynchronous_Control, -- (RM D.7(10))
|
||||||
|
No_Calendar, -- GNAT
|
||||||
|
No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2))
|
||||||
|
No_Delay, -- (RM H.4(21))
|
||||||
|
No_Direct_Boolean_Operators, -- GNAT
|
||||||
|
No_Dispatch, -- (RM H.4(19))
|
||||||
|
No_Dispatching_Calls, -- GNAT
|
||||||
|
No_Dynamic_Attachment, -- GNAT
|
||||||
|
No_Dynamic_Priorities, -- (RM D.9(9))
|
||||||
|
No_Enumeration_Maps, -- GNAT
|
||||||
|
No_Entry_Calls_In_Elaboration_Code, -- GNAT
|
||||||
|
No_Entry_Queue, -- GNAT (Ravenscar)
|
||||||
|
No_Exception_Handlers, -- GNAT
|
||||||
|
No_Exception_Propagation, -- GNAT
|
||||||
|
No_Exception_Registration, -- GNAT
|
||||||
|
No_Exceptions, -- (RM H.4(12))
|
||||||
|
No_Finalization, -- GNAT
|
||||||
|
No_Fixed_Point, -- (RM H.4(15))
|
||||||
|
No_Floating_Point, -- (RM H.4(14))
|
||||||
|
No_IO, -- (RM H.4(20))
|
||||||
|
No_Implicit_Conditionals, -- GNAT
|
||||||
|
No_Implicit_Dynamic_Code, -- GNAT
|
||||||
|
No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
|
||||||
|
No_Implicit_Loops, -- GNAT
|
||||||
|
No_Initialize_Scalars, -- GNAT
|
||||||
|
No_Local_Allocators, -- (RM H.4(8))
|
||||||
|
No_Local_Timing_Events, -- (RM D.7(10.2/2))
|
||||||
|
No_Local_Protected_Objects, -- GNAT
|
||||||
|
No_Nested_Finalization, -- (RM D.7(4))
|
||||||
|
No_Protected_Type_Allocators, -- GNAT
|
||||||
|
No_Protected_Types, -- (RM H.4(5))
|
||||||
|
No_Recursion, -- (RM H.4(22))
|
||||||
|
No_Reentrancy, -- (RM H.4(23))
|
||||||
|
No_Relative_Delay, -- GNAT (Ravenscar)
|
||||||
|
No_Requeue_Statements, -- GNAT
|
||||||
|
No_Secondary_Stack, -- GNAT
|
||||||
|
No_Select_Statements, -- GNAT (Ravenscar)
|
||||||
|
No_Specific_Termination_Handlers, -- (RM D.7(10.7/2))
|
||||||
|
No_Standard_Storage_Pools, -- GNAT
|
||||||
|
No_Stream_Optimizations, -- GNAT
|
||||||
|
No_Streams, -- GNAT
|
||||||
|
No_Task_Allocators, -- (RM D.7(7))
|
||||||
|
No_Task_Attributes_Package, -- GNAT
|
||||||
|
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
|
||||||
|
No_Task_Termination, -- GNAT (Ravenscar)
|
||||||
|
No_Tasking, -- GNAT
|
||||||
|
No_Terminate_Alternatives, -- (RM D.7(6))
|
||||||
|
No_Unchecked_Access, -- (RM H.4(18))
|
||||||
|
No_Unchecked_Conversion, -- (RM H.4(16))
|
||||||
|
No_Unchecked_Deallocation, -- (RM H.4(9))
|
||||||
|
Static_Priorities, -- GNAT
|
||||||
|
Static_Storage_Size, -- GNAT
|
||||||
|
|
||||||
|
-- The following require consistency checking with special rules. See
|
||||||
|
-- individual routines in unit Bcheck for details of what is required.
|
||||||
|
|
||||||
|
No_Default_Initialization, -- GNAT
|
||||||
|
|
||||||
|
-- The following cases do not require consistency checking and if used
|
||||||
|
-- as a configuration pragma within a specific unit, apply only to that
|
||||||
|
-- unit (e.g. if used in the package spec, do not apply to the body)
|
||||||
|
|
||||||
|
-- Note: No_Elaboration_Code is handled specially. Like the other
|
||||||
|
-- non-partition-wide restrictions, it can only be set in a unit that
|
||||||
|
-- is part of the extended main source unit (body/spec/subunits). But
|
||||||
|
-- it is sticky, in that if it is found anywhere within any of these
|
||||||
|
-- units, it applies to all units in this extended main source.
|
||||||
|
|
||||||
|
Immediate_Reclamation, -- (RM H.4(10))
|
||||||
|
No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241
|
||||||
|
No_Implementation_Attributes, -- Ada 2005 AI-257
|
||||||
|
No_Implementation_Identifiers, -- Ada 2012 AI-246
|
||||||
|
No_Implementation_Pragmas, -- Ada 2005 AI-257
|
||||||
|
No_Implementation_Restrictions, -- GNAT
|
||||||
|
No_Implementation_Units, -- Ada 2012 AI-242
|
||||||
|
No_Implicit_Aliasing, -- GNAT
|
||||||
|
No_Elaboration_Code, -- GNAT
|
||||||
|
No_Obsolescent_Features, -- Ada 2005 AI-368
|
||||||
|
No_Wide_Characters, -- GNAT
|
||||||
|
SPARK, -- GNAT
|
||||||
|
|
||||||
|
-- The following cases require a parameter value
|
||||||
|
|
||||||
|
-- The following entries are fully checked at compile/bind time, which
|
||||||
|
-- means that the compiler can in general tell the minimum value which
|
||||||
|
-- could be used with a restrictions pragma. The binder can deduce the
|
||||||
|
-- appropriate minimum value for the partition by taking the maximum
|
||||||
|
-- value required by any unit.
|
||||||
|
|
||||||
|
Max_Protected_Entries, -- (RM D.7(14))
|
||||||
|
Max_Select_Alternatives, -- (RM D.7(12))
|
||||||
|
Max_Task_Entries, -- (RM D.7(13), H.4(3))
|
||||||
|
|
||||||
|
-- The following entries are also fully checked at compile/bind time,
|
||||||
|
-- and the compiler can also at least in some cases tell the minimum
|
||||||
|
-- value which could be used with a restriction pragma. The difference
|
||||||
|
-- is that the contributions are additive, so the binder deduces this
|
||||||
|
-- value by adding the unit contributions.
|
||||||
|
|
||||||
|
Max_Tasks, -- (RM D.7(19), H.4(3))
|
||||||
|
|
||||||
|
-- The following entries are checked at compile time only for zero/
|
||||||
|
-- nonzero entries. This means that the compiler can tell at compile
|
||||||
|
-- time if a restriction value of zero is (would be) violated, but that
|
||||||
|
-- the compiler cannot distinguish between different non-zero values.
|
||||||
|
|
||||||
|
Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
|
||||||
|
Max_Entry_Queue_Length, -- GNAT
|
||||||
|
|
||||||
|
-- The remaining entries are not checked at compile/bind time
|
||||||
|
|
||||||
|
Max_Storage_At_Blocking, -- (RM D.7(17))
|
||||||
|
|
||||||
|
Not_A_Restriction_Id);
|
||||||
|
|
||||||
|
-- Synonyms permitted for historical purposes of compatibility.
|
||||||
|
-- Must be coordinated with Restrict.Process_Restriction_Synonym.
|
||||||
|
|
||||||
|
Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers;
|
||||||
|
Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length;
|
||||||
|
No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment;
|
||||||
|
No_Requeue : Restriction_Id renames No_Requeue_Statements;
|
||||||
|
No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package;
|
||||||
|
|
||||||
|
subtype All_Restrictions is Restriction_Id range
|
||||||
|
Simple_Barriers .. Max_Storage_At_Blocking;
|
||||||
|
-- All restrictions (excluding only Not_A_Restriction_Id)
|
||||||
|
|
||||||
|
subtype All_Boolean_Restrictions is Restriction_Id range
|
||||||
|
Simple_Barriers .. SPARK;
|
||||||
|
-- All restrictions which do not take a parameter
|
||||||
|
|
||||||
|
subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range
|
||||||
|
Simple_Barriers .. Static_Storage_Size;
|
||||||
|
-- Boolean restrictions that are checked for partition consistency.
|
||||||
|
-- Note that all parameter restrictions are checked for partition
|
||||||
|
-- consistency by default, so this distinction is only needed in the
|
||||||
|
-- case of Boolean restrictions.
|
||||||
|
|
||||||
|
subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range
|
||||||
|
Immediate_Reclamation .. SPARK;
|
||||||
|
-- Boolean restrictions that are not checked for partition consistency
|
||||||
|
-- and that thus apply only to the current unit. Note that for these
|
||||||
|
-- restrictions, the compiler does not apply restrictions found in
|
||||||
|
-- with'ed units, parent specs etc. to the main unit, and vice versa.
|
||||||
|
|
||||||
|
subtype All_Parameter_Restrictions is
|
||||||
|
Restriction_Id range
|
||||||
|
Max_Protected_Entries .. Max_Storage_At_Blocking;
|
||||||
|
-- All restrictions that take a parameter
|
||||||
|
|
||||||
|
subtype Checked_Parameter_Restrictions is
|
||||||
|
All_Parameter_Restrictions range
|
||||||
|
Max_Protected_Entries .. Max_Entry_Queue_Length;
|
||||||
|
-- These are the parameter restrictions that can be at least partially
|
||||||
|
-- checked at compile/binder time. Minimally, the compiler can detect
|
||||||
|
-- violations of a restriction pragma with a value of zero reliably.
|
||||||
|
|
||||||
|
subtype Checked_Max_Parameter_Restrictions is
|
||||||
|
Checked_Parameter_Restrictions range
|
||||||
|
Max_Protected_Entries .. Max_Task_Entries;
|
||||||
|
-- Restrictions with parameters that can be checked in some cases by
|
||||||
|
-- maximizing among statically detected instances where the compiler
|
||||||
|
-- can determine the count.
|
||||||
|
|
||||||
|
subtype Checked_Add_Parameter_Restrictions is
|
||||||
|
Checked_Parameter_Restrictions range
|
||||||
|
Max_Tasks .. Max_Tasks;
|
||||||
|
-- Restrictions with parameters that can be checked in some cases by
|
||||||
|
-- summing the statically detected instances where the compiler can
|
||||||
|
-- determine the count.
|
||||||
|
|
||||||
|
subtype Checked_Val_Parameter_Restrictions is
|
||||||
|
Checked_Parameter_Restrictions range
|
||||||
|
Max_Protected_Entries .. Max_Tasks;
|
||||||
|
-- Restrictions with parameter where the count is known at least in some
|
||||||
|
-- cases by the compiler/binder.
|
||||||
|
|
||||||
|
subtype Checked_Zero_Parameter_Restrictions is
|
||||||
|
Checked_Parameter_Restrictions range
|
||||||
|
Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length;
|
||||||
|
-- Restrictions with parameters where the compiler can detect the use of
|
||||||
|
-- the feature, and hence violations of a restriction specifying a value
|
||||||
|
-- of zero, but cannot detect specific values other than zero/nonzero.
|
||||||
|
|
||||||
|
subtype Unchecked_Parameter_Restrictions is
|
||||||
|
All_Parameter_Restrictions range
|
||||||
|
Max_Storage_At_Blocking .. Max_Storage_At_Blocking;
|
||||||
|
-- Restrictions with parameters where the compiler cannot ever detect
|
||||||
|
-- corresponding compile time usage, so the binder and compiler never
|
||||||
|
-- detect violations of any restriction.
|
||||||
|
|
||||||
|
-------------------------------------
|
||||||
|
-- Restriction Status Declarations --
|
||||||
|
-------------------------------------
|
||||||
|
|
||||||
|
-- The following declarations are used to record the current status or
|
||||||
|
-- restrictions (for the current unit, or related units, at compile time,
|
||||||
|
-- and for all units in a partition at bind time or run time).
|
||||||
|
|
||||||
|
type Restriction_Flags is array (All_Restrictions) of Boolean;
|
||||||
|
type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
|
||||||
|
type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean;
|
||||||
|
|
||||||
|
type Restrictions_Info is record
|
||||||
|
Set : Restriction_Flags;
|
||||||
|
-- An entry is True in the Set array if a restrictions pragma has been
|
||||||
|
-- encountered for the given restriction. If the value is True for a
|
||||||
|
-- parameter restriction, then the corresponding entry in the Value
|
||||||
|
-- array gives the minimum value encountered for any such restriction.
|
||||||
|
|
||||||
|
Value : Restriction_Values;
|
||||||
|
-- If the entry for a parameter restriction in Set is True (i.e. a
|
||||||
|
-- restrictions pragma for the restriction has been encountered), then
|
||||||
|
-- the corresponding entry in the Value array is the minimum value
|
||||||
|
-- specified by any such restrictions pragma. Note that a restrictions
|
||||||
|
-- pragma specifying a value greater than Int'Last is simply ignored.
|
||||||
|
|
||||||
|
Violated : Restriction_Flags;
|
||||||
|
-- An entry is True in the violations array if the compiler has detected
|
||||||
|
-- a violation of the restriction. For a parameter restriction, the
|
||||||
|
-- Count and Unknown arrays have additional information.
|
||||||
|
|
||||||
|
Count : Restriction_Values;
|
||||||
|
-- If an entry for a parameter restriction is True in Violated, the
|
||||||
|
-- corresponding entry in the Count array may record additional
|
||||||
|
-- information. If the actual minimum count is known (by taking
|
||||||
|
-- maximums, or sums, depending on the restriction), it will be
|
||||||
|
-- recorded in this array. If not, then the value will remain zero.
|
||||||
|
-- The value is also zero for a non-violated restriction.
|
||||||
|
|
||||||
|
Unknown : Parameter_Flags;
|
||||||
|
-- If an entry for a parameter restriction is True in Violated, the
|
||||||
|
-- corresponding entry in the Unknown array may record additional
|
||||||
|
-- information. If the actual count is not known by the compiler (but
|
||||||
|
-- is known to be non-zero), then the entry in Unknown will be True.
|
||||||
|
-- This indicates that the value in Count is not known to be exact,
|
||||||
|
-- and the actual violation count may be higher.
|
||||||
|
|
||||||
|
-- Note: If Violated (K) is True, then either Count (K) > 0 or
|
||||||
|
-- Unknown (K) = True. It is possible for both these to be set.
|
||||||
|
-- For example, if Count (K) = 3 and Unknown (K) is True, it means
|
||||||
|
-- that the actual violation count is at least 3 but might be higher.
|
||||||
|
end record;
|
||||||
|
|
||||||
|
No_Restrictions : constant Restrictions_Info :=
|
||||||
|
(Set => (others => False),
|
||||||
|
Value => (others => 0),
|
||||||
|
Violated => (others => False),
|
||||||
|
Count => (others => 0),
|
||||||
|
Unknown => (others => False));
|
||||||
|
-- Used to initialize Restrictions_Info variables
|
||||||
|
|
||||||
|
----------------------------------
|
||||||
|
-- Profile Definitions and Data --
|
||||||
|
----------------------------------
|
||||||
|
|
||||||
|
-- Note: to add a profile, modify the following declarations appropriately,
|
||||||
|
-- add Name_xxx to Snames, and add a branch to the conditions for pragmas
|
||||||
|
-- Profile and Profile_Warnings in the body of Sem_Prag.
|
||||||
|
|
||||||
|
type Profile_Name is
|
||||||
|
(No_Profile,
|
||||||
|
No_Implementation_Extensions,
|
||||||
|
Ravenscar,
|
||||||
|
Restricted);
|
||||||
|
-- Names of recognized profiles. No_Profile is used to indicate that a
|
||||||
|
-- restriction came from pragma Restrictions[_Warning], as opposed to
|
||||||
|
-- pragma Profile[_Warning].
|
||||||
|
|
||||||
|
subtype Profile_Name_Actual is Profile_Name
|
||||||
|
range No_Implementation_Extensions .. Restricted;
|
||||||
|
-- Actual used profile names
|
||||||
|
|
||||||
|
type Profile_Data is record
|
||||||
|
Set : Restriction_Flags;
|
||||||
|
-- Set to True if given restriction must be set for the profile, and
|
||||||
|
-- False if it need not be set (False does not mean that it must not be
|
||||||
|
-- set, just that it need not be set). If the flag is True for a
|
||||||
|
-- parameter restriction, then the Value array gives the maximum value
|
||||||
|
-- permitted by the profile.
|
||||||
|
|
||||||
|
Value : Restriction_Values;
|
||||||
|
-- An entry in this array is meaningful only if the corresponding flag
|
||||||
|
-- in Set is True. In that case, the value in this array is the maximum
|
||||||
|
-- value of the parameter permitted by the profile.
|
||||||
|
end record;
|
||||||
|
|
||||||
|
Profile_Info : constant array (Profile_Name_Actual) of Profile_Data :=
|
||||||
|
|
||||||
|
(No_Implementation_Extensions =>
|
||||||
|
-- Restrictions for Restricted profile
|
||||||
|
|
||||||
|
(Set =>
|
||||||
|
(No_Implementation_Aspect_Specifications => True,
|
||||||
|
No_Implementation_Attributes => True,
|
||||||
|
No_Implementation_Identifiers => True,
|
||||||
|
No_Implementation_Pragmas => True,
|
||||||
|
No_Implementation_Units => True,
|
||||||
|
others => False),
|
||||||
|
|
||||||
|
-- Value settings for Restricted profile (none
|
||||||
|
|
||||||
|
Value =>
|
||||||
|
(others => 0)),
|
||||||
|
|
||||||
|
-- Restricted Profile
|
||||||
|
|
||||||
|
Restricted =>
|
||||||
|
|
||||||
|
-- Restrictions for Restricted profile
|
||||||
|
|
||||||
|
(Set =>
|
||||||
|
(No_Abort_Statements => True,
|
||||||
|
No_Asynchronous_Control => True,
|
||||||
|
No_Dynamic_Attachment => True,
|
||||||
|
No_Dynamic_Priorities => True,
|
||||||
|
No_Entry_Queue => True,
|
||||||
|
No_Local_Protected_Objects => True,
|
||||||
|
No_Protected_Type_Allocators => True,
|
||||||
|
No_Requeue_Statements => True,
|
||||||
|
No_Task_Allocators => True,
|
||||||
|
No_Task_Attributes_Package => True,
|
||||||
|
No_Task_Hierarchy => True,
|
||||||
|
No_Terminate_Alternatives => True,
|
||||||
|
Max_Asynchronous_Select_Nesting => True,
|
||||||
|
Max_Protected_Entries => True,
|
||||||
|
Max_Select_Alternatives => True,
|
||||||
|
Max_Task_Entries => True,
|
||||||
|
others => False),
|
||||||
|
|
||||||
|
-- Value settings for Restricted profile
|
||||||
|
|
||||||
|
Value =>
|
||||||
|
(Max_Asynchronous_Select_Nesting => 0,
|
||||||
|
Max_Protected_Entries => 1,
|
||||||
|
Max_Select_Alternatives => 0,
|
||||||
|
Max_Task_Entries => 0,
|
||||||
|
others => 0)),
|
||||||
|
|
||||||
|
-- Ravenscar Profile
|
||||||
|
|
||||||
|
-- Note: the table entries here only represent the
|
||||||
|
-- required restriction profile for Ravenscar. The
|
||||||
|
-- full Ravenscar profile also requires:
|
||||||
|
|
||||||
|
-- pragma Dispatching_Policy (FIFO_Within_Priorities);
|
||||||
|
-- pragma Locking_Policy (Ceiling_Locking);
|
||||||
|
-- pragma Detect_Blocking
|
||||||
|
|
||||||
|
Ravenscar =>
|
||||||
|
|
||||||
|
-- Restrictions for Ravenscar = Restricted profile ..
|
||||||
|
|
||||||
|
(Set =>
|
||||||
|
(No_Abort_Statements => True,
|
||||||
|
No_Asynchronous_Control => True,
|
||||||
|
No_Dynamic_Attachment => True,
|
||||||
|
No_Dynamic_Priorities => True,
|
||||||
|
No_Entry_Queue => True,
|
||||||
|
No_Local_Protected_Objects => True,
|
||||||
|
No_Protected_Type_Allocators => True,
|
||||||
|
No_Requeue_Statements => True,
|
||||||
|
No_Task_Allocators => True,
|
||||||
|
No_Task_Attributes_Package => True,
|
||||||
|
No_Task_Hierarchy => True,
|
||||||
|
No_Terminate_Alternatives => True,
|
||||||
|
Max_Asynchronous_Select_Nesting => True,
|
||||||
|
Max_Protected_Entries => True,
|
||||||
|
Max_Select_Alternatives => True,
|
||||||
|
Max_Task_Entries => True,
|
||||||
|
|
||||||
|
-- plus these additional restrictions:
|
||||||
|
|
||||||
|
No_Calendar => True,
|
||||||
|
No_Implicit_Heap_Allocations => True,
|
||||||
|
No_Relative_Delay => True,
|
||||||
|
No_Select_Statements => True,
|
||||||
|
No_Task_Termination => True,
|
||||||
|
Simple_Barriers => True,
|
||||||
|
others => False),
|
||||||
|
|
||||||
|
-- Value settings for Ravenscar (same as Restricted)
|
||||||
|
|
||||||
|
Value =>
|
||||||
|
(Max_Asynchronous_Select_Nesting => 0,
|
||||||
|
Max_Protected_Entries => 1,
|
||||||
|
Max_Select_Alternatives => 0,
|
||||||
|
Max_Task_Entries => 0,
|
||||||
|
others => 0)));
|
||||||
|
|
||||||
|
end Rident;
|
||||||
|
|
|
@ -54,7 +54,6 @@ with System;
|
||||||
with System.Strings;
|
with System.Strings;
|
||||||
|
|
||||||
package System.OS_Lib is
|
package System.OS_Lib is
|
||||||
pragma Elaborate_Body (OS_Lib);
|
|
||||||
pragma Preelaborate;
|
pragma Preelaborate;
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
|
|
|
@ -716,57 +716,28 @@ package body System.Task_Primitives.Operations is
|
||||||
-- Set_Priority --
|
-- Set_Priority --
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
type Prio_Array_Type is array (System.Any_Priority) of Integer;
|
|
||||||
pragma Atomic_Components (Prio_Array_Type);
|
|
||||||
|
|
||||||
Prio_Array : Prio_Array_Type;
|
|
||||||
-- Global array containing the id of the currently running task for
|
|
||||||
-- each priority.
|
|
||||||
--
|
|
||||||
-- Note: we assume that we are on a single processor with run-til-blocked
|
|
||||||
-- scheduling.
|
|
||||||
|
|
||||||
procedure Set_Priority
|
procedure Set_Priority
|
||||||
(T : Task_Id;
|
(T : Task_Id;
|
||||||
Prio : System.Any_Priority;
|
Prio : System.Any_Priority;
|
||||||
Loss_Of_Inheritance : Boolean := False)
|
Loss_Of_Inheritance : Boolean := False)
|
||||||
is
|
is
|
||||||
Res : BOOL;
|
Res : BOOL;
|
||||||
Array_Item : Integer;
|
pragma Unreferenced (Loss_Of_Inheritance);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Res := SetThreadPriority
|
Res := SetThreadPriority
|
||||||
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
|
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
|
||||||
pragma Assert (Res = Win32.TRUE);
|
pragma Assert (Res = Win32.TRUE);
|
||||||
|
|
||||||
if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
|
-- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
|
||||||
|
-- head of its priority queue when decreasing its priority as a result
|
||||||
|
-- of a loss of inherited priority. This is not the case, but we
|
||||||
|
-- consider it an acceptable variation (RM 1.1.3(6)), given this is the
|
||||||
|
-- built-in behavior offered by the Windows operating system.
|
||||||
|
|
||||||
-- Annex D requirement [RM D.2.2 par. 9]:
|
-- In older versions we attempted to better approximate the Annex D
|
||||||
-- If the task drops its priority due to the loss of inherited
|
-- required behavior, but this simulation was not entirely accurate,
|
||||||
-- priority, it is added at the head of the ready queue for its
|
-- and it seems better to live with the standard Windows semantics.
|
||||||
-- new active priority.
|
|
||||||
|
|
||||||
if Loss_Of_Inheritance
|
|
||||||
and then Prio < T.Common.Current_Priority
|
|
||||||
then
|
|
||||||
Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
|
|
||||||
Prio_Array (T.Common.Base_Priority) := Array_Item;
|
|
||||||
|
|
||||||
loop
|
|
||||||
-- Let some processes a chance to arrive
|
|
||||||
|
|
||||||
Yield;
|
|
||||||
|
|
||||||
-- Then wait for our turn to proceed
|
|
||||||
|
|
||||||
exit when Array_Item = Prio_Array (T.Common.Base_Priority)
|
|
||||||
or else Prio_Array (T.Common.Base_Priority) = 1;
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
Prio_Array (T.Common.Base_Priority) :=
|
|
||||||
Prio_Array (T.Common.Base_Priority) - 1;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
T.Common.Current_Priority := Prio;
|
T.Common.Current_Priority := Prio;
|
||||||
end Set_Priority;
|
end Set_Priority;
|
||||||
|
|
|
@ -7735,6 +7735,18 @@ package body Sem_Ch13 is
|
||||||
begin
|
begin
|
||||||
Biased := False;
|
Biased := False;
|
||||||
|
|
||||||
|
-- Reject patently improper size values.
|
||||||
|
|
||||||
|
if Is_Scalar_Type (T)
|
||||||
|
and then Siz > UI_From_Int (Int'Last)
|
||||||
|
then
|
||||||
|
Error_Msg_N ("Size value too large for scalar type", N);
|
||||||
|
if Nkind (Original_Node (N)) = N_Op_Expon then
|
||||||
|
Error_Msg_N
|
||||||
|
("\maybe '* was meant, rather than '*'*", Original_Node (N));
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Dismiss cases for generic types or types with previous errors
|
-- Dismiss cases for generic types or types with previous errors
|
||||||
|
|
||||||
if No (UT)
|
if No (UT)
|
||||||
|
|
|
@ -139,87 +139,69 @@ package body Sem_Ch9 is
|
||||||
Priv_Decls : constant List_Id := Private_Declarations (Pdef);
|
Priv_Decls : constant List_Id := Private_Declarations (Pdef);
|
||||||
Vis_Decls : constant List_Id := Visible_Declarations (Pdef);
|
Vis_Decls : constant List_Id := Visible_Declarations (Pdef);
|
||||||
|
|
||||||
Comp_Id : Entity_Id;
|
Decl : Node_Id;
|
||||||
Comp_Size : Int;
|
|
||||||
Comp_Type : Entity_Id;
|
|
||||||
Decl : Node_Id;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Examine the visible declarations. Entries and entry families
|
-- Examine the visible and the private declarations
|
||||||
-- are not allowed by the lock-free restrictions.
|
|
||||||
|
|
||||||
Decl := First (Vis_Decls);
|
Decl := First (Vis_Decls);
|
||||||
while Present (Decl) loop
|
while Present (Decl) loop
|
||||||
|
|
||||||
|
-- Entries and entry families are not allowed by the lock-free
|
||||||
|
-- restrictions.
|
||||||
|
|
||||||
if Nkind (Decl) = N_Entry_Declaration then
|
if Nkind (Decl) = N_Entry_Declaration then
|
||||||
if Complain then
|
if Complain then
|
||||||
Error_Msg_N ("entry not allowed for lock-free " &
|
Error_Msg_N ("entry not allowed when Lock_Free given",
|
||||||
"implementation",
|
|
||||||
Decl);
|
Decl);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
return False;
|
return False;
|
||||||
end if;
|
|
||||||
|
|
||||||
Next (Decl);
|
-- Non-elementary out parameters in protected procedure are not
|
||||||
end loop;
|
-- allowed by the lock-free restrictions.
|
||||||
|
|
||||||
-- Examine the private declarations
|
elsif Nkind (Decl) = N_Subprogram_Declaration
|
||||||
|
and then Nkind (Specification (Decl)) =
|
||||||
|
N_Procedure_Specification
|
||||||
|
and then Present
|
||||||
|
(Parameter_Specifications (Specification (Decl)))
|
||||||
|
then
|
||||||
|
declare
|
||||||
|
Par_Specs : constant List_Id :=
|
||||||
|
Parameter_Specifications
|
||||||
|
(Specification (Decl));
|
||||||
|
Par : constant Node_Id := First (Par_Specs);
|
||||||
|
Par_Typ : constant Entity_Id :=
|
||||||
|
Etype (Parameter_Type (Par));
|
||||||
|
|
||||||
Decl := First (Priv_Decls);
|
begin
|
||||||
while Present (Decl) loop
|
if Out_Present (Par)
|
||||||
|
and then not Is_Elementary_Type (Par_Typ)
|
||||||
-- The protected type must define at least one scalar component
|
then
|
||||||
|
|
||||||
if Nkind (Decl) = N_Component_Declaration then
|
|
||||||
Comp_Id := Defining_Identifier (Decl);
|
|
||||||
Comp_Type := Etype (Comp_Id);
|
|
||||||
|
|
||||||
-- Make sure the protected component type has size and
|
|
||||||
-- alignment fields set at this point whenever this is
|
|
||||||
-- possible.
|
|
||||||
|
|
||||||
Layout_Type (Comp_Type);
|
|
||||||
|
|
||||||
if Known_Esize (Comp_Type) then
|
|
||||||
Comp_Size := UI_To_Int (Esize (Comp_Type));
|
|
||||||
|
|
||||||
-- If the Esize (Object_Size) is unknown at compile-time,
|
|
||||||
-- look at the RM_Size (Value_Size) since it may have been
|
|
||||||
-- set by an explicit representation clause.
|
|
||||||
|
|
||||||
else
|
|
||||||
Comp_Size := UI_To_Int (RM_Size (Comp_Type));
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Check that the size of the component is 8, 16, 32 or 64
|
|
||||||
-- bits.
|
|
||||||
|
|
||||||
case Comp_Size is
|
|
||||||
when 8 | 16 | 32 | 64 =>
|
|
||||||
null;
|
|
||||||
when others =>
|
|
||||||
if Complain then
|
if Complain then
|
||||||
Error_Msg_N ("must support atomic operations for " &
|
Error_Msg_NE
|
||||||
"lock-free implementation",
|
("non-elementary out parameter& not allowed " &
|
||||||
Decl);
|
"when Lock_Free given",
|
||||||
|
Par,
|
||||||
|
Defining_Identifier (Par));
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
return False;
|
return False;
|
||||||
end case;
|
end if;
|
||||||
|
end;
|
||||||
-- Entries and entry families are not allowed
|
|
||||||
|
|
||||||
elsif Nkind (Decl) = N_Entry_Declaration then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_N ("entry not allowed for lock-free " &
|
|
||||||
"implementation",
|
|
||||||
Decl);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return False;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Next (Decl);
|
-- Examine the private declarations after the visible
|
||||||
|
-- declarations.
|
||||||
|
|
||||||
|
if No (Next (Decl))
|
||||||
|
and then List_Containing (Decl) = Vis_Decls
|
||||||
|
then
|
||||||
|
Decl := First (Priv_Decls);
|
||||||
|
else
|
||||||
|
Next (Decl);
|
||||||
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
@ -248,6 +230,11 @@ package body Sem_Ch9 is
|
||||||
function Satisfies_Lock_Free_Requirements
|
function Satisfies_Lock_Free_Requirements
|
||||||
(Sub_Body : Node_Id) return Boolean
|
(Sub_Body : Node_Id) return Boolean
|
||||||
is
|
is
|
||||||
|
Is_Procedure : constant Boolean :=
|
||||||
|
Ekind (Corresponding_Spec (Sub_Body)) =
|
||||||
|
E_Procedure;
|
||||||
|
-- Indicates if Sub_Body is a procedure body
|
||||||
|
|
||||||
Comp : Entity_Id := Empty;
|
Comp : Entity_Id := Empty;
|
||||||
-- Track the current component which the body references
|
-- Track the current component which the body references
|
||||||
|
|
||||||
|
@ -260,152 +247,160 @@ package body Sem_Ch9 is
|
||||||
|
|
||||||
function Check_Node (N : Node_Id) return Traverse_Result is
|
function Check_Node (N : Node_Id) return Traverse_Result is
|
||||||
begin
|
begin
|
||||||
-- Function calls and attribute references must be static
|
if Is_Procedure then
|
||||||
|
-- Function calls and attribute references must be static
|
||||||
|
|
||||||
if Nkind (N) = N_Attribute_Reference
|
if Nkind (N) = N_Attribute_Reference
|
||||||
and then not Is_Static_Expression (N)
|
and then not Is_Static_Expression (N)
|
||||||
then
|
then
|
||||||
if Complain then
|
if Complain then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
("non-static attribute reference not allowed",
|
("non-static attribute reference not allowed", N);
|
||||||
N);
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
|
|
||||||
|
elsif Nkind (N) = N_Function_Call
|
||||||
|
and then not Is_Static_Expression (N)
|
||||||
|
then
|
||||||
|
if Complain then
|
||||||
|
Error_Msg_N ("non-static function call not allowed",
|
||||||
|
N);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
|
|
||||||
|
-- Loop statements and procedure calls are prohibited
|
||||||
|
|
||||||
|
elsif Nkind (N) = N_Loop_Statement then
|
||||||
|
if Complain then
|
||||||
|
Error_Msg_N ("loop not allowed", N);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
|
|
||||||
|
elsif Nkind (N) = N_Procedure_Call_Statement then
|
||||||
|
if Complain then
|
||||||
|
Error_Msg_N ("procedure call not allowed", N);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
|
|
||||||
|
-- References
|
||||||
|
|
||||||
|
elsif Nkind (N) = N_Identifier
|
||||||
|
and then Present (Entity (N))
|
||||||
|
then
|
||||||
|
declare
|
||||||
|
Id : constant Entity_Id := Entity (N);
|
||||||
|
Sub_Id : constant Entity_Id :=
|
||||||
|
Corresponding_Spec (Sub_Body);
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- Prohibit references to non-constant entities
|
||||||
|
-- outside the protected subprogram scope.
|
||||||
|
|
||||||
|
if Ekind (Id) in Assignable_Kind
|
||||||
|
and then not Scope_Within_Or_Same (Scope (Id),
|
||||||
|
Sub_Id)
|
||||||
|
and then not Scope_Within_Or_Same (Scope (Id),
|
||||||
|
Protected_Body_Subprogram (Sub_Id))
|
||||||
|
then
|
||||||
|
if Complain then
|
||||||
|
Error_Msg_NE
|
||||||
|
("reference to global variable& not " &
|
||||||
|
"allowed", N, Id);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
end if;
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
return Abandon;
|
-- A protected subprogram (function or procedure) may
|
||||||
|
-- reference only one component of the protected type, plus
|
||||||
|
-- the type of the component must support atomic operation.
|
||||||
|
|
||||||
elsif Nkind (N) = N_Function_Call
|
if Nkind (N) = N_Identifier
|
||||||
and then not Is_Static_Expression (N)
|
|
||||||
then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_N ("non-static function call not allowed",
|
|
||||||
N);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
|
|
||||||
-- Loop statements and procedure calls are prohibited
|
|
||||||
|
|
||||||
elsif Nkind (N) = N_Loop_Statement then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_N ("loop not allowed", N);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
|
|
||||||
elsif Nkind (N) = N_Procedure_Call_Statement then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_N ("procedure call not allowed", N);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
|
|
||||||
-- References
|
|
||||||
|
|
||||||
elsif Nkind (N) = N_Identifier
|
|
||||||
and then Present (Entity (N))
|
and then Present (Entity (N))
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Id : constant Entity_Id := Entity (N);
|
Id : constant Entity_Id := Entity (N);
|
||||||
Sub_Id : constant Entity_Id :=
|
Comp_Decl : Node_Id;
|
||||||
Corresponding_Spec (Sub_Body);
|
Comp_Id : Entity_Id := Empty;
|
||||||
|
Comp_Size : Int;
|
||||||
|
Comp_Type : Entity_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Prohibit references to non-constant entities
|
if Ekind (Id) = E_Component then
|
||||||
-- outside the protected subprogram scope.
|
Comp_Id := Id;
|
||||||
|
|
||||||
if Ekind (Id) in Assignable_Kind
|
|
||||||
and then not Scope_Within_Or_Same (Scope (Id),
|
|
||||||
Sub_Id)
|
|
||||||
and then not Scope_Within_Or_Same (Scope (Id),
|
|
||||||
Protected_Body_Subprogram (Sub_Id))
|
|
||||||
then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_NE
|
|
||||||
("reference to global variable& not allowed",
|
|
||||||
N, Id);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
|
|
||||||
-- Prohibit non-scalar out parameters (scalar
|
|
||||||
-- parameters are passed by copy).
|
|
||||||
|
|
||||||
elsif Ekind_In (Id, E_Out_Parameter,
|
|
||||||
E_In_Out_Parameter)
|
|
||||||
and then not Is_Elementary_Type (Etype (Id))
|
|
||||||
and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
|
|
||||||
then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_NE
|
|
||||||
("non-elementary out parameter& not allowed",
|
|
||||||
N, Id);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
|
|
||||||
-- A protected subprogram may reference only one
|
|
||||||
-- component of the protected type.
|
|
||||||
|
|
||||||
elsif Ekind (Id) = E_Component then
|
|
||||||
declare
|
|
||||||
Comp_Decl : constant Node_Id := Parent (Id);
|
|
||||||
begin
|
|
||||||
if Nkind (Comp_Decl) = N_Component_Declaration
|
|
||||||
and then Is_List_Member (Comp_Decl)
|
|
||||||
and then List_Containing (Comp_Decl) =
|
|
||||||
Priv_Decls
|
|
||||||
then
|
|
||||||
if No (Comp) then
|
|
||||||
Comp := Id;
|
|
||||||
|
|
||||||
-- Check if another protected component has
|
|
||||||
-- already been accessed by the subprogram
|
|
||||||
-- body.
|
|
||||||
|
|
||||||
elsif Comp /= Id then
|
|
||||||
if Complain then
|
|
||||||
Error_Msg_N
|
|
||||||
("only one protected component " &
|
|
||||||
"allowed",
|
|
||||||
N);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Abandon;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end;
|
|
||||||
|
|
||||||
elsif Ekind_In (Id, E_Constant, E_Variable)
|
elsif Ekind_In (Id, E_Constant, E_Variable)
|
||||||
and then Present (Prival_Link (Id))
|
and then Present (Prival_Link (Id))
|
||||||
then
|
then
|
||||||
declare
|
Comp_Id := Prival_Link (Id);
|
||||||
Comp_Decl : constant Node_Id :=
|
end if;
|
||||||
Parent (Prival_Link (Id));
|
|
||||||
begin
|
|
||||||
if Nkind (Comp_Decl) = N_Component_Declaration
|
|
||||||
and then Is_List_Member (Comp_Decl)
|
|
||||||
and then List_Containing (Comp_Decl) =
|
|
||||||
Priv_Decls
|
|
||||||
then
|
|
||||||
if No (Comp) then
|
|
||||||
Comp := Prival_Link (Id);
|
|
||||||
|
|
||||||
-- Check if another protected component has
|
if Present (Comp_Id) then
|
||||||
-- already been accessed by the subprogram
|
Comp_Decl := Parent (Comp_Id);
|
||||||
-- body.
|
Comp_Type := Etype (Comp_Id);
|
||||||
|
|
||||||
elsif Comp /= Prival_Link (Id) then
|
if Nkind (Comp_Decl) = N_Component_Declaration
|
||||||
|
and then Is_List_Member (Comp_Decl)
|
||||||
|
and then List_Containing (Comp_Decl) = Priv_Decls
|
||||||
|
then
|
||||||
|
-- Make sure the protected component type has
|
||||||
|
-- size and alignment fields set at this point
|
||||||
|
-- whenever this is possible.
|
||||||
|
|
||||||
|
Layout_Type (Comp_Type);
|
||||||
|
|
||||||
|
if Known_Esize (Comp_Type) then
|
||||||
|
Comp_Size := UI_To_Int (Esize (Comp_Type));
|
||||||
|
|
||||||
|
-- If the Esize (Object_Size) is unknown at
|
||||||
|
-- compile-time, look at the RM_Size
|
||||||
|
-- (Value_Size) since it may have been set by an
|
||||||
|
-- explicit representation clause.
|
||||||
|
|
||||||
|
else
|
||||||
|
Comp_Size := UI_To_Int (RM_Size (Comp_Type));
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Check that the size of the component is 8,
|
||||||
|
-- 16, 32 or 64 bits.
|
||||||
|
|
||||||
|
case Comp_Size is
|
||||||
|
when 8 | 16 | 32 | 64 =>
|
||||||
|
null;
|
||||||
|
when others =>
|
||||||
if Complain then
|
if Complain then
|
||||||
Error_Msg_N
|
Error_Msg_NE
|
||||||
("only one protected component " &
|
("type of& must support atomic " &
|
||||||
"allowed",
|
"operations",
|
||||||
N);
|
N, Comp_Id);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
return Abandon;
|
return Abandon;
|
||||||
|
end case;
|
||||||
|
|
||||||
|
-- Check if another protected component has
|
||||||
|
-- already been accessed by the subprogram body.
|
||||||
|
|
||||||
|
if No (Comp) then
|
||||||
|
Comp := Id;
|
||||||
|
|
||||||
|
elsif Comp /= Id then
|
||||||
|
if Complain then
|
||||||
|
Error_Msg_N
|
||||||
|
("only one protected component allowed",
|
||||||
|
N);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
return Abandon;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
|
@ -444,7 +439,7 @@ package body Sem_Ch9 is
|
||||||
and then not Satisfies_Lock_Free_Requirements (Decl)
|
and then not Satisfies_Lock_Free_Requirements (Decl)
|
||||||
then
|
then
|
||||||
if Complain then
|
if Complain then
|
||||||
Error_Msg_N ("body prevents lock-free implementation",
|
Error_Msg_N ("body not allowed when Lock_Free given",
|
||||||
Decl);
|
Decl);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -1787,6 +1782,43 @@ package body Sem_Ch9 is
|
||||||
-- issued by Allows_Lock_Free_Implementation.
|
-- issued by Allows_Lock_Free_Implementation.
|
||||||
|
|
||||||
if Uses_Lock_Free (Defining_Identifier (N)) then
|
if Uses_Lock_Free (Defining_Identifier (N)) then
|
||||||
|
-- Complain when there is an explicit aspect/pragma Priority (or
|
||||||
|
-- Interrupt_Priority) while the lock-free implementation is forced
|
||||||
|
-- by an aspect/pragma.
|
||||||
|
|
||||||
|
declare
|
||||||
|
Id : constant Entity_Id :=
|
||||||
|
Defining_Identifier (Original_Node (N));
|
||||||
|
-- The warning must be issued on the original identifier in order
|
||||||
|
-- to deal properly with the case of a single protected object.
|
||||||
|
|
||||||
|
Prio_Item : constant Node_Id :=
|
||||||
|
Get_Rep_Item
|
||||||
|
(Defining_Identifier (N),
|
||||||
|
Name_Priority,
|
||||||
|
Check_Parents => False);
|
||||||
|
|
||||||
|
begin
|
||||||
|
if Present (Prio_Item) then
|
||||||
|
-- Aspect case
|
||||||
|
|
||||||
|
if Nkind (Prio_Item) = N_Aspect_Specification
|
||||||
|
or else From_Aspect_Specification (Prio_Item)
|
||||||
|
then
|
||||||
|
Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
|
||||||
|
Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" &
|
||||||
|
" given", Prio_Item, Id);
|
||||||
|
|
||||||
|
-- Pragma case
|
||||||
|
|
||||||
|
else
|
||||||
|
Error_Msg_Name_1 := Pragma_Name (Prio_Item);
|
||||||
|
Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" &
|
||||||
|
" given", Prio_Item, Id);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
|
||||||
if not Allows_Lock_Free_Implementation (N, Complain => True) then
|
if not Allows_Lock_Free_Implementation (N, Complain => True) then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -432,7 +432,7 @@ package body Sem_Dim is
|
||||||
------------------------------
|
------------------------------
|
||||||
|
|
||||||
-- with Dimension => (
|
-- with Dimension => (
|
||||||
-- [Symbol =>] SYMBOL,
|
-- [[Symbol =>] SYMBOL,]
|
||||||
-- DIMENSION_VALUE
|
-- DIMENSION_VALUE
|
||||||
-- [, DIMENSION_VALUE]
|
-- [, DIMENSION_VALUE]
|
||||||
-- [, DIMENSION_VALUE]
|
-- [, DIMENSION_VALUE]
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -1696,7 +1696,9 @@ package body Sem_Disp is
|
||||||
Ctrl_Type : Entity_Id;
|
Ctrl_Type : Entity_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Present (DTC_Entity (Subp)) then
|
if Ekind_In (Subp, E_Function, E_Procedure)
|
||||||
|
and then Present (DTC_Entity (Subp))
|
||||||
|
then
|
||||||
return Scope (DTC_Entity (Subp));
|
return Scope (DTC_Entity (Subp));
|
||||||
|
|
||||||
-- For subprograms internally generated by derivations of tagged types
|
-- For subprograms internally generated by derivations of tagged types
|
||||||
|
|
|
@ -6254,7 +6254,7 @@ package body Sem_Prag is
|
||||||
|
|
||||||
-- Set Detect_Blocking mode
|
-- Set Detect_Blocking mode
|
||||||
|
|
||||||
-- Set required restrictions (see System.Rident for detailed list)
|
-- Set required restrictions (see Rident for detailed list)
|
||||||
|
|
||||||
-- Set the No_Dependence rules
|
-- Set the No_Dependence rules
|
||||||
-- No_Dependence => Ada.Asynchronous_Task_Control
|
-- No_Dependence => Ada.Asynchronous_Task_Control
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
* *
|
* *
|
||||||
* C Implementation File *
|
* C Implementation File *
|
||||||
* *
|
* *
|
||||||
* Copyright (C) 2000-2011, Free Software Foundation, Inc. *
|
* Copyright (C) 2000-2012, Free Software Foundation, Inc. *
|
||||||
* *
|
* *
|
||||||
* GNAT is free software; you can redistribute it and/or modify it under *
|
* 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- *
|
* terms of the GNU General Public License as published by the Free Soft- *
|
||||||
|
@ -106,6 +106,76 @@ extern void (*Unlock_Task) (void);
|
||||||
|
|
||||||
#include "tb-ivms.c"
|
#include "tb-ivms.c"
|
||||||
|
|
||||||
|
#elif defined (_WIN64) && defined (__SEH__)
|
||||||
|
|
||||||
|
#include <windows.h>
|
||||||
|
|
||||||
|
int
|
||||||
|
__gnat_backtrace (void **array,
|
||||||
|
int size,
|
||||||
|
void *exclude_min,
|
||||||
|
void *exclude_max,
|
||||||
|
int skip_frames)
|
||||||
|
{
|
||||||
|
CONTEXT context;
|
||||||
|
UNWIND_HISTORY_TABLE history;
|
||||||
|
int i;
|
||||||
|
|
||||||
|
/* Get the context. */
|
||||||
|
RtlCaptureContext (&context);
|
||||||
|
|
||||||
|
/* Setup unwind history table (a cached to speed-up unwinding). */
|
||||||
|
memset (&history, 0, sizeof (history));
|
||||||
|
|
||||||
|
i = 0;
|
||||||
|
while (1)
|
||||||
|
{
|
||||||
|
PRUNTIME_FUNCTION RuntimeFunction;
|
||||||
|
KNONVOLATILE_CONTEXT_POINTERS NvContext;
|
||||||
|
ULONG64 ImageBase;
|
||||||
|
VOID *HandlerData;
|
||||||
|
ULONG64 EstablisherFrame;
|
||||||
|
|
||||||
|
/* Get function metadata. */
|
||||||
|
RuntimeFunction = RtlLookupFunctionEntry
|
||||||
|
(context.Rip, &ImageBase, &history);
|
||||||
|
|
||||||
|
if (!RuntimeFunction)
|
||||||
|
{
|
||||||
|
/* In case of failure, assume this is a leaf function. */
|
||||||
|
context.Rip = *(ULONG64 **) context.Rsp;
|
||||||
|
context.Rsp += 8;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
/* Unwind. */
|
||||||
|
memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS));
|
||||||
|
RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction,
|
||||||
|
&context, &HandlerData, &EstablisherFrame,
|
||||||
|
&NvContext);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* 0 means bottom of the stack. */
|
||||||
|
if (context.Rip == 0)
|
||||||
|
break;
|
||||||
|
|
||||||
|
/* Skip frames. */
|
||||||
|
if (skip_frames)
|
||||||
|
{
|
||||||
|
skip_frames--;
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
/* Excluded frames. */
|
||||||
|
if ((void *)context.Rip >= exclude_min
|
||||||
|
&& (void *)context.Rip <= exclude_max)
|
||||||
|
continue;
|
||||||
|
|
||||||
|
array[i++] = context.Rip - 2;
|
||||||
|
if (i >= size)
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
return i;
|
||||||
|
}
|
||||||
#else
|
#else
|
||||||
|
|
||||||
/* No target specific implementation. */
|
/* No target specific implementation. */
|
||||||
|
|
Loading…
Reference in New Issue