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>
* 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
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;
......
gcc/ada/einfo.ads
......@@ -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)
......
gcc/ada/exp_ch8.adb
......@@ -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;
......
gcc/ada/exp_disp.adb
......@@ -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 ");
......
gcc/ada/freeze.adb
......@@ -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
-- 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
......
gcc/ada/restrict.adb
......@@ -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
......
gcc/ada/restrict.ads
......@@ -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);
......
gcc/ada/s-os_lib.ads
......@@ -54,7 +54,6 @@ with System;
with System.Strings;
package System.OS_Lib is
pragma Elaborate_Body (OS_Lib);
pragma Preelaborate;
-----------------------
......
gcc/ada/s-taprop-mingw.adb
......@@ -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
-- 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;
......
gcc/ada/sem_ch13.adb
......@@ -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)
......
gcc/ada/sem_dim.adb
......@@ -432,7 +432,7 @@ package body Sem_Dim is
------------------------------
-- with Dimension => (
-- [Symbol =>] SYMBOL,
-- [[Symbol =>] SYMBOL,]
-- DIMENSION_VALUE
-- [, DIMENSION_VALUE]
-- [, DIMENSION_VALUE]
......
gcc/ada/sem_disp.adb
......@@ -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
......
gcc/ada/sem_prag.adb
......@@ -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
......
gcc/ada/tracebak.c
......@@ -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. */
......
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