Skip to content

R
riscv-gcc-1
Commit 22a83cea by Arnaud Charlet
Options

[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
parent a2c1791d
Showing with 326 additions and 106 deletions
gcc/ada/ChangeLog
2012-07-09 Thomas Quinot <quinot@adacore.com>
* einfo.adb (Set_Reverse_Storage_Order): Update assertion,
flag is now valid for array types as well.
2012-07-09 Tristan Gingold <gingold@adacore.com>
* tracebak.c: Implement __gnat_backtrace for Win64 SEH.
2012-07-09 Robert Dewar <dewar@adacore.com>
* einfo.ads: Minor reformatting.
2012-07-09 Javier Miranda <miranda@adacore.com>
* exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Handle as
renaming_as_body renamings of predefined dispatching equality
and unequality operators.
2012-07-09 Robert Dewar <dewar@adacore.com>
* rident.ads: Do not instantiate r-ident.ads, this is now an
independent unit.
2012-07-09 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Write_DT): Avoid runtime crash of this debugging
routine.
* sem_disp.adb (Find_Dispatching_Time): Protect this routine
against partially decorated entities.
2012-07-09 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Check_Size): Reject a size clause that specifies
a value greater than Int'Last for a scalar type.
2012-07-09 Vincent Pucci <pucci@adacore.com>
* sem_ch9.adb (Allows_Lock_Free_Implementation): type must support
atomic operation moved to the protected body case. No non-elementary
out parameter moved to the protected declaration case. Functions have
only one lock-free restriction.
(Analyze_Protected_Type_Declaration): Issue a warning when
Priority given with Lock_Free.
2012-07-09 Vincent Pucci <pucci@adacore.com>
* sem_dim.adb: Grammar of aspect Dimension fixed.
2012-07-09 Vincent Pucci <pucci@adacore.com>
* freeze.adb (Freeze_Record_Type): Code reorg in order to avoid
pushing and popping the scope stack whenever a delayed aspect occurs.
2012-07-09 Gary Dismukes <dismukes@adacore.com>
* s-os_lib.ads: Remove pragma Elaborate_Body, as
this is now unnecessary due to recently added pragma Preelaborate.
2012-07-09 Jose Ruiz <ruiz@adacore.com>
* s-taprop-mingw.adb (Set_Priority): Remove the code that was
previously in place to reorder the ready queue when a task drops
its priority due to the loss of inherited priority.
2012-07-09 Robert Dewar <dewar@adacore.com> 2012-07-09 Robert Dewar <dewar@adacore.com>
* layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb, * layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb,
......
gcc/ada/einfo.adb
...@@ -5163,7 +5163,8 @@ package body Einfo is ...@@ -5163,7 +5163,8 @@ package body Einfo is
procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is
begin begin
pragma Assert pragma Assert
(Is_Record_Type (Id) and then Is_Base_Type (Id)); (Is_Base_Type (Id)
and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
Set_Flag93 (Id, V); Set_Flag93 (Id, V);
end Set_Reverse_Storage_Order; end Set_Reverse_Storage_Order;
......
gcc/ada/einfo.ads
...@@ -5021,6 +5021,7 @@ package Einfo is ...@@ -5021,6 +5021,7 @@ package Einfo is
-- Has_Component_Size_Clause (Flag68) (base type only) -- Has_Component_Size_Clause (Flag68) (base type only)
-- Has_Pragma_Pack (Flag121) (impl base type only) -- Has_Pragma_Pack (Flag121) (impl base type only)
-- Is_Constrained (Flag12) -- Is_Constrained (Flag12)
-- Reverse_Storage_Order (Flag93) (base type only)
-- Next_Index (synth) -- Next_Index (synth)
-- Number_Dimensions (synth) -- Number_Dimensions (synth)
-- (plus type attributes) -- (plus type attributes)
......
gcc/ada/exp_ch8.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -239,6 +239,44 @@ package body Exp_Ch8 is ...@@ -239,6 +239,44 @@ package body Exp_Ch8 is
---------------------------------------------- ----------------------------------------------
procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Entity (N);
function Build_Body_For_Renaming return Node_Id;
-- Build and return the body for the renaming declaration of an
-- equality or unequality operator.
function Build_Body_For_Renaming return Node_Id is
Body_Id : Entity_Id;
Decl : Node_Id;
begin
Set_Alias (Id, Empty);
Set_Has_Completion (Id, False);
Rewrite (N,
Make_Subprogram_Declaration (Sloc (N),
Specification => Specification (N)));
Set_Has_Delayed_Freeze (Id);
Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
Set_Debug_Info_Needed (Body_Id);
Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications => Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence => Empty);
return Decl;
end Build_Body_For_Renaming;
-- Local variable
Nam : constant Node_Id := Name (N); Nam : constant Node_Id := Name (N);
begin begin
...@@ -259,25 +297,26 @@ package body Exp_Ch8 is ...@@ -259,25 +297,26 @@ package body Exp_Ch8 is
Force_Evaluation (Prefix (Nam)); Force_Evaluation (Prefix (Nam));
end if; end if;
-- Check whether this is a renaming of a predefined equality on an -- Handle cases where we build a body for a renamed equality
-- untagged record type (AI05-0123).
if Is_Entity_Name (Nam) if Is_Entity_Name (Nam)
and then Chars (Entity (Nam)) = Name_Op_Eq and then (Chars (Entity (Nam)) = Name_Op_Ne
or else Chars (Entity (Nam)) = Name_Op_Eq)
and then Scope (Entity (Nam)) = Standard_Standard and then Scope (Entity (Nam)) = Standard_Standard
and then Ada_Version >= Ada_2012
then then
declare declare
Loc : constant Source_Ptr := Sloc (N); Left : constant Entity_Id := First_Formal (Id);
Id : constant Entity_Id := Defining_Entity (N); Right : constant Entity_Id := Next_Formal (Left);
Typ : constant Entity_Id := Etype (First_Formal (Id)); Typ : constant Entity_Id := Etype (Left);
Decl : Node_Id;
Decl : Node_Id;
Body_Id : constant Entity_Id :=
Make_Defining_Identifier (Sloc (N), Chars (Id));
begin begin
if Is_Record_Type (Typ) -- Check whether this is a renaming of a predefined equality on an
-- untagged record type (AI05-0123).
if Ada_Version >= Ada_2012
and then Chars (Entity (Nam)) = Name_Op_Eq
and then Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ) and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ) and then not Is_Frozen (Typ)
then then
...@@ -288,23 +327,7 @@ package body Exp_Ch8 is ...@@ -288,23 +327,7 @@ package body Exp_Ch8 is
-- declaration, and the body is inserted at the end of the -- declaration, and the body is inserted at the end of the
-- current declaration list to prevent premature freezing. -- current declaration list to prevent premature freezing.
Set_Alias (Id, Empty); Decl := Build_Body_For_Renaming;
Set_Has_Completion (Id, False);
Rewrite (N,
Make_Subprogram_Declaration (Sloc (N),
Specification => Specification (N)));
Set_Has_Delayed_Freeze (Id);
Decl := Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications =>
Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence => Empty);
Set_Handled_Statement_Sequence (Decl, Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
...@@ -322,7 +345,63 @@ package body Exp_Ch8 is ...@@ -322,7 +345,63 @@ package body Exp_Ch8 is
Bodies => Declarations (Decl)))))); Bodies => Declarations (Decl))))));
Append (Decl, List_Containing (N)); Append (Decl, List_Containing (N));
Set_Debug_Info_Needed (Body_Id);
-- Handle renamings of predefined dispatching equality operators.
-- When we analyze a renaming of the equality operator of a tagged
-- type, the predefined dispatching primitives are not available
-- (since they are added by the expander when the tagged type is
-- frozen) and hence they are left decorated as renamings of the
-- standard non-dispatching operators. Here we generate a body
-- for such renamings which invokes the predefined dispatching
-- equality operator.
-- Example:
-- type T is tagged null record;
-- function Eq (X, Y : T1) return Boolean renames "=";
-- function Neq (X, Y : T1) return Boolean renames "/=";
elsif Is_Record_Type (Typ)
and then Is_Tagged_Type (Typ)
and then Is_Dispatching_Operation (Id)
and then not Is_Dispatching_Operation (Entity (Nam))
then
pragma Assert (not Is_Frozen (Typ));
Decl := Build_Body_For_Renaming;
-- Clean decoration of intrinsic subprogram
Set_Is_Intrinsic_Subprogram (Id, False);
Set_Convention (Id, Convention_Ada);
if Chars (Entity (Nam)) = Name_Op_Ne then
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Op_Not (Loc,
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (Left, Loc),
Right_Opnd =>
New_Reference_To (Right, Loc)))))));
else pragma Assert (Chars (Entity (Nam)) = Name_Op_Eq);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (Left, Loc),
Right_Opnd =>
New_Reference_To (Right, Loc))))));
end if;
Append (Decl, List_Containing (N));
end if; end if;
end; end;
end if; end if;
......
gcc/ada/exp_disp.adb
...@@ -5777,7 +5777,7 @@ package body Exp_Disp is ...@@ -5777,7 +5777,7 @@ package body Exp_Disp is
Prefix => New_Reference_To (TSD, Loc), Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address)); Attribute_Name => Name_Address));
-- Stage 2: Initialize the table of primitive operations -- Stage 2: Initialize the table of user-defined primitive operations
Prim_Ops_Aggr_List := New_List; Prim_Ops_Aggr_List := New_List;
...@@ -8857,7 +8857,8 @@ package body Exp_Disp is ...@@ -8857,7 +8857,8 @@ package body Exp_Disp is
-- If the DTC_Entity attribute is already set we can also output -- If the DTC_Entity attribute is already set we can also output
-- the name of the interface covered by this primitive (if any). -- the name of the interface covered by this primitive (if any).
if Present (DTC_Entity (Alias (Prim))) if Ekind_In (Alias (Prim), E_Function, E_Procedure)
and then Present (DTC_Entity (Alias (Prim)))
and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
then then
Write_Str (" from interface "); Write_Str (" from interface ");
......
gcc/ada/freeze.adb
...@@ -1814,6 +1814,11 @@ package body Freeze is ...@@ -1814,6 +1814,11 @@ package body Freeze is
Junk : Boolean; Junk : Boolean;
pragma Warnings (Off, Junk); pragma Warnings (Off, Junk);
Rec_Pushed : Boolean := False;
-- Set True if the record type scope Rec has been pushed on the scope
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
Unplaced_Component : Boolean := False; Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component -- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas). -- clause (used to warn about useless Pack pragmas).
...@@ -1901,39 +1906,53 @@ package body Freeze is ...@@ -1901,39 +1906,53 @@ package body Freeze is
-- Start of processing for Freeze_Record_Type -- Start of processing for Freeze_Record_Type
begin 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); Comp := First_Entity (Rec);
Prev := Empty;
while Present (Comp) loop while Present (Comp) loop
-- Deal with delayed aspect specifications for components. The
-- analysis of the aspect is required to be delayed to the freeze
-- point, thus we analyze the pragma or attribute definition
-- clause in the tree at this point. We also analyze the aspect
-- specification node at the freeze point when the aspect doesn't
-- correspond to pragma/attribute definition clause.
if Ekind (Comp) = E_Component if Ekind (Comp) = E_Component
and then Has_Delayed_Aspects (Comp) and then Has_Delayed_Aspects (Comp)
then then
Push_Scope (Rec); if not Rec_Pushed then
Push_Scope (Rec);
-- The visibility to the discriminants must be restored in Rec_Pushed := True;
-- order to properly analyze the aspects.
if Has_Discriminants (Rec) then -- The visibility to the discriminants must be restored in
Install_Discriminants (Rec); -- order to properly analyze the aspects.
Analyze_Aspects_At_Freeze_Point (Comp);
Uninstall_Discriminants (Rec);
else if Has_Discriminants (Rec) then
Analyze_Aspects_At_Freeze_Point (Comp); Install_Discriminants (Rec);
end if;
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; 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 -- Handle the component and discriminant case
if Ekind (Comp) = E_Component if Ekind (Comp) = E_Component
......
gcc/ada/restrict.adb
...@@ -768,7 +768,7 @@ package body Restrict is ...@@ -768,7 +768,7 @@ package body Restrict is
---------------------------------- ----------------------------------
-- Note: body of this function must be coordinated with list of -- Note: body of this function must be coordinated with list of
-- renaming declarations in System.Rident. -- renaming declarations in Rident.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
is is
......
gcc/ada/restrict.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -332,10 +332,10 @@ package Restrict is ...@@ -332,10 +332,10 @@ package Restrict is
-- exception propagation is activated. -- exception propagation is activated.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
-- Id is a node whose Chars field contains the name of a restriction. -- Id is a node whose Chars field contains the name of a restriction. If it
-- If it is one of synonyms that we allow for historical purposes (for -- is one of synonyms that we allow for historical purposes (for list see
-- list see System.Rident), then the proper official name is returned. -- Rident), then the proper official name is returned. Otherwise the Chars
-- Otherwise the Chars field of the argument is returned unchanged. -- field of the argument is returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean; function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active); pragma Inline (Restriction_Active);
......
gcc/ada/s-os_lib.ads
...@@ -54,7 +54,6 @@ with System; ...@@ -54,7 +54,6 @@ with System;
with System.Strings; with System.Strings;
package System.OS_Lib is package System.OS_Lib is
pragma Elaborate_Body (OS_Lib);
pragma Preelaborate; pragma Preelaborate;
----------------------- -----------------------
......
gcc/ada/s-taprop-mingw.adb
...@@ -716,57 +716,28 @@ package body System.Task_Primitives.Operations is ...@@ -716,57 +716,28 @@ package body System.Task_Primitives.Operations is
-- Set_Priority -- -- Set_Priority --
------------------ ------------------
type Prio_Array_Type is array (System.Any_Priority) of Integer;
pragma Atomic_Components (Prio_Array_Type);
Prio_Array : Prio_Array_Type;
-- Global array containing the id of the currently running task for
-- each priority.
--
-- Note: we assume that we are on a single processor with run-til-blocked
-- scheduling.
procedure Set_Priority procedure Set_Priority
(T : Task_Id; (T : Task_Id;
Prio : System.Any_Priority; Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False) Loss_Of_Inheritance : Boolean := False)
is is
Res : BOOL; Res : BOOL;
Array_Item : Integer; pragma Unreferenced (Loss_Of_Inheritance);
begin begin
Res := SetThreadPriority Res := SetThreadPriority
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
pragma Assert (Res = Win32.TRUE); pragma Assert (Res = Win32.TRUE);
if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
-- head of its priority queue when decreasing its priority as a result
-- Annex D requirement [RM D.2.2 par. 9]: -- of a loss of inherited priority. This is not the case, but we
-- If the task drops its priority due to the loss of inherited -- consider it an acceptable variation (RM 1.1.3(6)), given this is the
-- priority, it is added at the head of the ready queue for its -- built-in behavior offered by the Windows operating system.
-- 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 -- In older versions we attempted to better approximate the Annex D
-- required behavior, but this simulation was not entirely accurate,
exit when Array_Item = Prio_Array (T.Common.Base_Priority) -- and it seems better to live with the standard Windows semantics.
or else Prio_Array (T.Common.Base_Priority) = 1;
end loop;
Prio_Array (T.Common.Base_Priority) :=
Prio_Array (T.Common.Base_Priority) - 1;
end if;
end if;
T.Common.Current_Priority := Prio; T.Common.Current_Priority := Prio;
end Set_Priority; end Set_Priority;
......
gcc/ada/sem_ch13.adb
...@@ -7735,6 +7735,18 @@ package body Sem_Ch13 is ...@@ -7735,6 +7735,18 @@ package body Sem_Ch13 is
begin begin
Biased := False; Biased := False;
-- Reject patently improper size values.
if Is_Scalar_Type (T)
and then Siz > UI_From_Int (Int'Last)
then
Error_Msg_N ("Size value too large for scalar type", N);
if Nkind (Original_Node (N)) = N_Op_Expon then
Error_Msg_N
("\maybe '* was meant, rather than '*'*", Original_Node (N));
end if;
end if;
-- Dismiss cases for generic types or types with previous errors -- Dismiss cases for generic types or types with previous errors
if No (UT) if No (UT)
......
gcc/ada/sem_dim.adb
...@@ -432,7 +432,7 @@ package body Sem_Dim is ...@@ -432,7 +432,7 @@ package body Sem_Dim is
------------------------------ ------------------------------
-- with Dimension => ( -- with Dimension => (
-- [Symbol =>] SYMBOL, -- [[Symbol =>] SYMBOL,]
-- DIMENSION_VALUE -- DIMENSION_VALUE
-- [, DIMENSION_VALUE] -- [, DIMENSION_VALUE]
-- [, DIMENSION_VALUE] -- [, DIMENSION_VALUE]
......
gcc/ada/sem_disp.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1696,7 +1696,9 @@ package body Sem_Disp is ...@@ -1696,7 +1696,9 @@ package body Sem_Disp is
Ctrl_Type : Entity_Id; Ctrl_Type : Entity_Id;
begin begin
if Present (DTC_Entity (Subp)) then if Ekind_In (Subp, E_Function, E_Procedure)
and then Present (DTC_Entity (Subp))
then
return Scope (DTC_Entity (Subp)); return Scope (DTC_Entity (Subp));
-- For subprograms internally generated by derivations of tagged types -- For subprograms internally generated by derivations of tagged types
......
gcc/ada/sem_prag.adb
...@@ -6254,7 +6254,7 @@ package body Sem_Prag is ...@@ -6254,7 +6254,7 @@ package body Sem_Prag is
-- Set Detect_Blocking mode -- Set Detect_Blocking mode
-- Set required restrictions (see System.Rident for detailed list) -- Set required restrictions (see Rident for detailed list)
-- Set the No_Dependence rules -- Set the No_Dependence rules
-- No_Dependence => Ada.Asynchronous_Task_Control -- No_Dependence => Ada.Asynchronous_Task_Control
......
gcc/ada/tracebak.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * C Implementation File *
* * * *
* Copyright (C) 2000-2011, Free Software Foundation, Inc. * * Copyright (C) 2000-2012, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -106,6 +106,76 @@ extern void (*Unlock_Task) (void); ...@@ -106,6 +106,76 @@ extern void (*Unlock_Task) (void);
#include "tb-ivms.c" #include "tb-ivms.c"
#elif defined (_WIN64) && defined (__SEH__)
#include <windows.h>
int
__gnat_backtrace (void **array,
int size,
void *exclude_min,
void *exclude_max,
int skip_frames)
{
CONTEXT context;
UNWIND_HISTORY_TABLE history;
int i;
/* Get the context. */
RtlCaptureContext (&context);
/* Setup unwind history table (a cached to speed-up unwinding). */
memset (&history, 0, sizeof (history));
i = 0;
while (1)
{
PRUNTIME_FUNCTION RuntimeFunction;
KNONVOLATILE_CONTEXT_POINTERS NvContext;
ULONG64 ImageBase;
VOID *HandlerData;
ULONG64 EstablisherFrame;
/* Get function metadata. */
RuntimeFunction = RtlLookupFunctionEntry
(context.Rip, &ImageBase, &history);
if (!RuntimeFunction)
{
/* In case of failure, assume this is a leaf function. */
context.Rip = *(ULONG64 **) context.Rsp;
context.Rsp += 8;
}
else
{
/* Unwind. */
memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS));
RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction,
&context, &HandlerData, &EstablisherFrame,
&NvContext);
}
/* 0 means bottom of the stack. */
if (context.Rip == 0)
break;
/* Skip frames. */
if (skip_frames)
{
skip_frames--;
continue;
}
/* Excluded frames. */
if ((void *)context.Rip >= exclude_min
&& (void *)context.Rip <= exclude_max)
continue;
array[i++] = context.Rip - 2;
if (i >= size)
break;
}
return i;
}
#else #else
/* No target specific implementation. */ /* No target specific implementation. */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment