+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,
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;
-- 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)
-- --
-- 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- --
----------------------------------------------
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
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
-- 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,
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;
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;
-- 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 ");
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).
-- Start of processing for Freeze_Record_Type
begin
- -- Freeze components and embedded subtypes
+ -- 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);
- 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 not Rec_Pushed then
+ Push_Scope (Rec);
+ Rec_Pushed := True;
- if Has_Discriminants (Rec) then
- Install_Discriminants (Rec);
- Analyze_Aspects_At_Freeze_Point (Comp);
- Uninstall_Discriminants (Rec);
+ -- The visibility to the discriminants must be restored in
+ -- order to properly analyze the aspects.
- else
- Analyze_Aspects_At_Freeze_Point (Comp);
+ if Has_Discriminants (Rec) then
+ Install_Discriminants (Rec);
+ end if;
end if;
- Pop_Scope;
+ 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
+
-- Handle the component and discriminant case
if Ekind (Comp) = E_Component
----------------------------------
-- 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
-- --
-- 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- --
-- 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);
-- --
-- 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- --
-- 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;
with System.Strings;
package System.OS_Lib is
- pragma Elaborate_Body (OS_Lib);
pragma Preelaborate;
-----------------------
-- 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
-
- -- 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;
+ -- 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.
- -- 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;
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)
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;
-
- -- Examine the private declarations
-
- 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.
+ -- Non-elementary out parameters in protected procedure are not
+ -- allowed by the lock-free restrictions.
- 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.
+ 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));
- 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
+ end if;
+ end;
+ end if;
- elsif Nkind (Decl) = N_Entry_Declaration then
- if Complain then
- Error_Msg_N ("entry not allowed for lock-free " &
- "implementation",
- Decl);
- end if;
+ -- Examine the private declarations after the visible
+ -- declarations.
- return False;
+ if No (Next (Decl))
+ and then List_Containing (Decl) = Vis_Decls
+ then
+ Decl := First (Priv_Decls);
+ else
+ Next (Decl);
end if;
-
- Next (Decl);
end loop;
end;
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
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);
- end if;
+ 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;
+ 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;
+ 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;
+ return Abandon;
- -- Loop statements and procedure calls are prohibited
+ -- 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;
+ elsif Nkind (N) = N_Loop_Statement then
+ if Complain then
+ Error_Msg_N ("loop not allowed", N);
+ end if;
- return Abandon;
+ return Abandon;
- elsif Nkind (N) = N_Procedure_Call_Statement then
- if Complain then
- Error_Msg_N ("procedure call not allowed", N);
- end if;
+ 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;
+ return Abandon;
+ end if;
+ end;
+ end if;
+ end if;
- -- References
+ -- 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_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))
+ if Ekind (Id) = E_Component then
+ Comp_Id := Id;
+
+ elsif Ekind_In (Id, E_Constant, E_Variable)
+ and then Present (Prival_Link (Id))
then
- if Complain then
- Error_Msg_NE
- ("reference to global variable& not allowed",
- N, Id);
- end if;
+ Comp_Id := Prival_Link (Id);
+ end if;
- return Abandon;
+ if Present (Comp_Id) then
+ Comp_Decl := Parent (Comp_Id);
+ Comp_Type := Etype (Comp_Id);
- -- Prohibit non-scalar out parameters (scalar
- -- parameters are passed by copy).
+ 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.
- 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;
+ Layout_Type (Comp_Type);
- return Abandon;
+ if Known_Esize (Comp_Type) then
+ Comp_Size := UI_To_Int (Esize (Comp_Type));
- -- A protected subprogram may reference only one
- -- component of the protected 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.
- 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;
+ else
+ Comp_Size := UI_To_Int (RM_Size (Comp_Type));
+ end if;
- -- Check if another protected component has
- -- already been accessed by the subprogram
- -- body.
+ -- Check that the size of the component is 8,
+ -- 16, 32 or 64 bits.
- elsif Comp /= Id then
+ 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 if;
- end if;
- end;
+ end case;
- 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);
-
- -- Check if another protected component has
- -- already been accessed by the subprogram
- -- body.
-
- elsif Comp /= Prival_Link (Id) then
- if Complain then
- Error_Msg_N
- ("only one protected component " &
- "allowed",
- N);
- end if;
+ -- Check if another protected component has
+ -- already been accessed by the subprogram body.
- return Abandon;
+ 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;
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;
-- 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;
------------------------------
-- with Dimension => (
- -- [Symbol =>] SYMBOL,
+ -- [[Symbol =>] SYMBOL,]
-- DIMENSION_VALUE
-- [, DIMENSION_VALUE]
-- [, DIMENSION_VALUE]
-- --
-- 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- --
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
-- 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
* *
* 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- *
#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. */
projects / thirdparty / gcc.git / commitdiff
