[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:
Arnaud Charlet
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>
|
||||
|
||||
* 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
|
||||
begin
|
||||
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);
|
||||
end Set_Reverse_Storage_Order;
|
||||
|
||||
|
|
|
|||
|
|
@ -5021,6 +5021,7 @@ package Einfo is
|
|||
-- Has_Component_Size_Clause (Flag68) (base type only)
|
||||
-- Has_Pragma_Pack (Flag121) (impl base type only)
|
||||
-- Is_Constrained (Flag12)
|
||||
-- Reverse_Storage_Order (Flag93) (base type only)
|
||||
-- Next_Index (synth)
|
||||
-- Number_Dimensions (synth)
|
||||
-- (plus type attributes)
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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 --
|
||||
-- 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
|
||||
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);
|
||||
|
||||
begin
|
||||
|
|
@ -259,25 +297,26 @@ package body Exp_Ch8 is
|
|||
Force_Evaluation (Prefix (Nam));
|
||||
end if;
|
||||
|
||||
-- Check whether this is a renaming of a predefined equality on an
|
||||
-- untagged record type (AI05-0123).
|
||||
-- Handle cases where we build a body for a renamed equality
|
||||
|
||||
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 Ada_Version >= Ada_2012
|
||||
then
|
||||
declare
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Id : constant Entity_Id := Defining_Entity (N);
|
||||
Typ : constant Entity_Id := Etype (First_Formal (Id));
|
||||
|
||||
Decl : Node_Id;
|
||||
Body_Id : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Sloc (N), Chars (Id));
|
||||
Left : constant Entity_Id := First_Formal (Id);
|
||||
Right : constant Entity_Id := Next_Formal (Left);
|
||||
Typ : constant Entity_Id := Etype (Left);
|
||||
Decl : Node_Id;
|
||||
|
||||
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_Frozen (Typ)
|
||||
then
|
||||
|
|
@ -288,23 +327,7 @@ package body Exp_Ch8 is
|
|||
-- declaration, and the body is inserted at the end of the
|
||||
-- current declaration list to prevent premature freezing.
|
||||
|
||||
Set_Alias (Id, Empty);
|
||||
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);
|
||||
Decl := Build_Body_For_Renaming;
|
||||
|
||||
Set_Handled_Statement_Sequence (Decl,
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
|
|
@ -322,7 +345,63 @@ package body Exp_Ch8 is
|
|||
Bodies => Declarations (Decl))))));
|
||||
|
||||
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;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -5777,7 +5777,7 @@ package body Exp_Disp is
|
|||
Prefix => New_Reference_To (TSD, Loc),
|
||||
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;
|
||||
|
||||
|
|
@ -8857,7 +8857,8 @@ package body Exp_Disp is
|
|||
-- If the DTC_Entity attribute is already set we can also output
|
||||
-- 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))))
|
||||
then
|
||||
Write_Str (" from interface ");
|
||||
|
|
|
|||
|
|
@ -1814,6 +1814,11 @@ package body Freeze is
|
|||
Junk : Boolean;
|
||||
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;
|
||||
-- Set True if we find at least one component with no component
|
||||
-- clause (used to warn about useless Pack pragmas).
|
||||
|
|
@ -1901,39 +1906,53 @@ package body Freeze is
|
|||
-- Start of processing for Freeze_Record_Type
|
||||
|
||||
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
|
||||
|
||||
Comp := First_Entity (Rec);
|
||||
Prev := Empty;
|
||||
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
|
||||
|
||||
if Ekind (Comp) = E_Component
|
||||
|
|
|
|||
|
|
@ -768,7 +768,7 @@ package body Restrict is
|
|||
----------------------------------
|
||||
|
||||
-- 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
|
||||
is
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -332,10 +332,10 @@ package Restrict is
|
|||
-- exception propagation is activated.
|
||||
|
||||
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
|
||||
-- Id is a node whose Chars field contains the name of a restriction.
|
||||
-- If it is one of synonyms that we allow for historical purposes (for
|
||||
-- list see System.Rident), then the proper official name is returned.
|
||||
-- Otherwise the Chars field of the argument is returned unchanged.
|
||||
-- Id is a node whose Chars field contains the name of a restriction. If it
|
||||
-- is one of synonyms that we allow for historical purposes (for list see
|
||||
-- Rident), then the proper official name is returned. Otherwise the Chars
|
||||
-- field of the argument is returned unchanged.
|
||||
|
||||
function Restriction_Active (R : All_Restrictions) return Boolean;
|
||||
pragma Inline (Restriction_Active);
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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 --
|
||||
-- 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
|
||||
-- packages.
|
||||
|
||||
-- Note: the actual definitions of the types are in package System.Rident,
|
||||
-- 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.
|
||||
package Rident is
|
||||
|
||||
-- Rather than have clients instantiate System.Rident directly, we have the
|
||||
-- single instantiation here at the library level, which means that we only
|
||||
-- have one copy of the image tables
|
||||
-- The following enumeration type defines the set of restriction
|
||||
-- identifiers that are implemented in GNAT.
|
||||
|
||||
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;
|
||||
|
||||
package System.OS_Lib is
|
||||
pragma Elaborate_Body (OS_Lib);
|
||||
pragma Preelaborate;
|
||||
|
||||
-----------------------
|
||||
|
|
|
|||
|
|
@ -716,57 +716,28 @@ package body System.Task_Primitives.Operations is
|
|||
-- 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
|
||||
(T : Task_Id;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False)
|
||||
is
|
||||
Res : BOOL;
|
||||
Array_Item : Integer;
|
||||
Res : BOOL;
|
||||
pragma Unreferenced (Loss_Of_Inheritance);
|
||||
|
||||
begin
|
||||
Res := SetThreadPriority
|
||||
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
|
||||
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]:
|
||||
-- If the task drops its priority due to the loss of inherited
|
||||
-- priority, it is added at the head of the ready queue for its
|
||||
-- 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;
|
||||
-- In older versions we attempted to better approximate the Annex D
|
||||
-- required behavior, but this simulation was not entirely accurate,
|
||||
-- and it seems better to live with the standard Windows semantics.
|
||||
|
||||
T.Common.Current_Priority := Prio;
|
||||
end Set_Priority;
|
||||
|
|
|
|||
|
|
@ -7735,6 +7735,18 @@ package body Sem_Ch13 is
|
|||
begin
|
||||
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
|
||||
|
||||
if No (UT)
|
||||
|
|
|
|||
|
|
@ -139,87 +139,69 @@ package body Sem_Ch9 is
|
|||
Priv_Decls : constant List_Id := Private_Declarations (Pdef);
|
||||
Vis_Decls : constant List_Id := Visible_Declarations (Pdef);
|
||||
|
||||
Comp_Id : Entity_Id;
|
||||
Comp_Size : Int;
|
||||
Comp_Type : Entity_Id;
|
||||
Decl : Node_Id;
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
-- Examine the visible declarations. Entries and entry families
|
||||
-- are not allowed by the lock-free restrictions.
|
||||
-- Examine the visible and the private declarations
|
||||
|
||||
Decl := First (Vis_Decls);
|
||||
while Present (Decl) loop
|
||||
|
||||
-- Entries and entry families are not allowed by the lock-free
|
||||
-- restrictions.
|
||||
|
||||
if Nkind (Decl) = N_Entry_Declaration then
|
||||
if Complain then
|
||||
Error_Msg_N ("entry not allowed for lock-free " &
|
||||
"implementation",
|
||||
Error_Msg_N ("entry not allowed when Lock_Free given",
|
||||
Decl);
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Next (Decl);
|
||||
end loop;
|
||||
-- Non-elementary out parameters in protected procedure are not
|
||||
-- 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);
|
||||
while Present (Decl) loop
|
||||
|
||||
-- The protected type must define at least one scalar component
|
||||
|
||||
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 =>
|
||||
begin
|
||||
if Out_Present (Par)
|
||||
and then not Is_Elementary_Type (Par_Typ)
|
||||
then
|
||||
if Complain then
|
||||
Error_Msg_N ("must support atomic operations for " &
|
||||
"lock-free implementation",
|
||||
Decl);
|
||||
Error_Msg_NE
|
||||
("non-elementary out parameter& not allowed " &
|
||||
"when Lock_Free given",
|
||||
Par,
|
||||
Defining_Identifier (Par));
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end case;
|
||||
|
||||
-- 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;
|
||||
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;
|
||||
|
||||
|
|
@ -248,6 +230,11 @@ package body Sem_Ch9 is
|
|||
function Satisfies_Lock_Free_Requirements
|
||||
(Sub_Body : Node_Id) return Boolean
|
||||
is
|
||||
Is_Procedure : constant Boolean :=
|
||||
Ekind (Corresponding_Spec (Sub_Body)) =
|
||||
E_Procedure;
|
||||
-- Indicates if Sub_Body is a procedure body
|
||||
|
||||
Comp : Entity_Id := Empty;
|
||||
-- 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
|
||||
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
|
||||
and then not Is_Static_Expression (N)
|
||||
then
|
||||
if Complain then
|
||||
Error_Msg_N
|
||||
("non-static attribute reference not allowed",
|
||||
N);
|
||||
if Nkind (N) = N_Attribute_Reference
|
||||
and then not Is_Static_Expression (N)
|
||||
then
|
||||
if Complain then
|
||||
Error_Msg_N
|
||||
("non-static attribute reference not allowed", 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;
|
||||
|
||||
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
|
||||
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
|
||||
if 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);
|
||||
Id : constant Entity_Id := Entity (N);
|
||||
Comp_Decl : Node_Id;
|
||||
Comp_Id : Entity_Id := Empty;
|
||||
Comp_Size : Int;
|
||||
Comp_Type : Entity_Id;
|
||||
|
||||
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;
|
||||
|
||||
-- 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;
|
||||
if Ekind (Id) = E_Component then
|
||||
Comp_Id := Id;
|
||||
|
||||
elsif Ekind_In (Id, E_Constant, E_Variable)
|
||||
and then Present (Prival_Link (Id))
|
||||
then
|
||||
declare
|
||||
Comp_Decl : constant Node_Id :=
|
||||
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);
|
||||
Comp_Id := Prival_Link (Id);
|
||||
end if;
|
||||
|
||||
-- Check if another protected component has
|
||||
-- already been accessed by the subprogram
|
||||
-- body.
|
||||
if Present (Comp_Id) then
|
||||
Comp_Decl := Parent (Comp_Id);
|
||||
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
|
||||
Error_Msg_N
|
||||
("only one protected component " &
|
||||
"allowed",
|
||||
N);
|
||||
Error_Msg_NE
|
||||
("type of& must support atomic " &
|
||||
"operations",
|
||||
N, Comp_Id);
|
||||
end if;
|
||||
|
||||
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;
|
||||
|
||||
return Abandon;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
|
@ -444,7 +439,7 @@ package body Sem_Ch9 is
|
|||
and then not Satisfies_Lock_Free_Requirements (Decl)
|
||||
then
|
||||
if Complain then
|
||||
Error_Msg_N ("body prevents lock-free implementation",
|
||||
Error_Msg_N ("body not allowed when Lock_Free given",
|
||||
Decl);
|
||||
end if;
|
||||
|
||||
|
|
@ -1787,6 +1782,43 @@ package body Sem_Ch9 is
|
|||
-- issued by Allows_Lock_Free_Implementation.
|
||||
|
||||
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
|
||||
return;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -432,7 +432,7 @@ package body Sem_Dim is
|
|||
------------------------------
|
||||
|
||||
-- with Dimension => (
|
||||
-- [Symbol =>] SYMBOL,
|
||||
-- [[Symbol =>] SYMBOL,]
|
||||
-- DIMENSION_VALUE
|
||||
-- [, DIMENSION_VALUE]
|
||||
-- [, DIMENSION_VALUE]
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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 --
|
||||
-- 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;
|
||||
|
||||
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));
|
||||
|
||||
-- For subprograms internally generated by derivations of tagged types
|
||||
|
|
|
|||
|
|
@ -6254,7 +6254,7 @@ package body Sem_Prag is
|
|||
|
||||
-- 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
|
||||
-- No_Dependence => Ada.Asynchronous_Task_Control
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
* *
|
||||
* 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 *
|
||||
* 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"
|
||||
|
||||
#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
|
||||
|
||||
/* No target specific implementation. */
|
||||
|
|
|
|||
Loading…
Reference in New Issue