mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-22 11:31:05 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-02-24  Robert Dewar  <dewar@adacore.com>

	* a-tags.adb, s-os_lib.adb: Minor reformatting.

2014-02-24  Thomas Quinot  <quinot@adacore.com>

	* g-sercom-mingw.adb, g-sercom-linux.adb (Raise_Error): Include
	strerror message, not just numeric errno value.

2014-02-24  Doug Rupp  <rupp@adacore.com>

	* raise-gcc.c (exception_class_eq): Make endian neutral.

2014-02-24  Ed Schonberg  <schonberg@adacore.com>

	* atree.ads, atree,adb (Copy_Separate_Tree): Remove Syntax_Only
	flag, and reset Etype and Analyzed attributes unconditionally
	when copying a tree that may be partly analyzed.
	* freeze.adb: Change calls to Copy_Separate_Tree accordingly.
	* sem_ch6.adb (Check_Inline_Pragma): If the Inline pragma appears
	within a subprogram body and applies to it, remove it from the
	body before making a copy of it, to prevent spurious errors when
	analyzing the copied body.

From-SVN: r208086
This commit is contained in:
Arnaud Charlet 2014-02-24 18:06:34 +01:00
parent 5c20e503ba
commit 158d55fa39
10 changed files with 117 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/ada/ChangeLog
View File

@ -1,3 +1,27 @@
2014-02-24 Robert Dewar <dewar@adacore.com>
* a-tags.adb, s-os_lib.adb: Minor reformatting.
2014-02-24 Thomas Quinot <quinot@adacore.com>
* g-sercom-mingw.adb, g-sercom-linux.adb (Raise_Error): Include
strerror message, not just numeric errno value.
2014-02-24 Doug Rupp <rupp@adacore.com>
* raise-gcc.c (exception_class_eq): Make endian neutral.
2014-02-24 Ed Schonberg <schonberg@adacore.com>
* atree.ads, atree,adb (Copy_Separate_Tree): Remove Syntax_Only
flag, and reset Etype and Analyzed attributes unconditionally
when copying a tree that may be partly analyzed.
* freeze.adb: Change calls to Copy_Separate_Tree accordingly.
* sem_ch6.adb (Check_Inline_Pragma): If the Inline pragma appears
within a subprogram body and applies to it, remove it from the
body before making a copy of it, to prevent spurious errors when
analyzing the copied body.
2014-02-24 Thomas Quinot <quinot@adacore.com>
* s-os_lib.adb (Errno_Message): Do not depend on Integer'Image.

50
gcc/ada/a-tags.adb
View File

@ -31,6 +31,7 @@
with Ada.Exceptions;
with Ada.Unchecked_Conversion;
with System.HTable;
with System.Storage_Elements; use System.Storage_Elements;
with System.WCh_Con; use System.WCh_Con;
@ -58,7 +59,8 @@ package body Ada.Tags is
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
-- as a C-style string, which is Nul terminated). See comment in body
-- explaining why we cannot use the normal strlen built-in.
function OSD (T : Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
@ -179,7 +181,7 @@ package body Ada.Tags is
function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
begin
return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD;
@ -190,9 +192,9 @@ package body Ada.Tags is
function SSD (T : Tag) return Select_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD.SSD;
end SSD;
@ -241,8 +243,9 @@ package body Ada.Tags is
function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
J : Integer;
begin
J := 1;
loop
if Str1 (J) /= Str2 (J) then
return False;
@ -260,9 +263,9 @@ package body Ada.Tags is
function Get_HT_Link (T : Tag) return Tag is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD.HT_Link.all;
end Get_HT_Link;
@ -285,9 +288,9 @@ package body Ada.Tags is
procedure Set_HT_Link (T : Tag; Next : Tag) is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
TSD.HT_Link.all := Next;
end Set_HT_Link;
@ -357,10 +360,7 @@ package body Ada.Tags is
-- Displace --
--------------
function Displace
(This : System.Address;
T : Tag) return System.Address
is
function Displace (This : System.Address; T : Tag) return System.Address is
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Dispatch_Table_Ptr;
@ -418,7 +418,7 @@ package body Ada.Tags is
function DT (T : Tag) return Dispatch_Table_Ptr is
Offset : constant SSE.Storage_Offset :=
To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
begin
return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
end DT;
@ -561,9 +561,9 @@ package body Ada.Tags is
function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
begin
@ -573,6 +573,7 @@ package body Ada.Tags is
begin
return Table;
end;
else
declare
Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
@ -605,13 +606,13 @@ package body Ada.Tags is
if External'Length > Internal_Tag_Header'Length
and then
External (External'First ..
External'First + Internal_Tag_Header'Length - 1)
= Internal_Tag_Header
External (External'First ..
External'First + Internal_Tag_Header'Length - 1) =
Internal_Tag_Header
then
declare
Addr_First : constant Natural :=
External'First + Internal_Tag_Header'Length;
External'First + Internal_Tag_Header'Length;
Addr_Last : Natural;
Addr : Integer_Address;
@ -783,9 +784,9 @@ package body Ada.Tags is
function Needs_Finalization (T : Tag) return Boolean is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD.Needs_Finalization;
end Needs_Finalization;
@ -803,9 +804,9 @@ package body Ada.Tags is
-- ancestor tags.
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- Pointer to the TSD
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
@ -961,6 +962,7 @@ package body Ada.Tags is
is
Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr;
begin
-- Save the offset to top field in the secondary dispatch table

65
gcc/ada/atree.adb
View File

@ -772,9 +772,7 @@ package body Atree is
-- Copy_Separate_Tree --
------------------------
function Copy_Separate_Tree
(Source : Node_Id;
Syntax_Only : Boolean := False) return Node_Id
function Copy_Separate_Tree (Source : Node_Id) return Node_Id
is
New_Id : Node_Id;
@ -796,9 +794,7 @@ package body Atree is
New_Ent : Entity_Id;
begin
-- Build appropriate node. Note that in this case, we do not need to
-- do any special casing for Syntax_Only, since the new node has no
-- Etype set, and is always unanalyzed.
-- Build appropriate node.
case N_Entity (Nkind (E)) is
when N_Defining_Identifier =>
@ -835,7 +831,7 @@ package body Atree is
if Has_Extension (E) then
Append (Copy_Entity (E), NL);
else
Append (Copy_Separate_Tree (E, Syntax_Only), NL);
Append (Copy_Separate_Tree (E), NL);
end if;
Next (E);
@ -855,7 +851,7 @@ package body Atree is
begin
if Field in Node_Range then
New_N :=
Union_Id (Copy_Separate_Tree (Node_Id (Field), Syntax_Only));
Union_Id (Copy_Separate_Tree (Node_Id (Field)));
if Parent (Node_Id (Field)) = Source then
Set_Parent (Node_Id (New_N), New_Id);
@ -906,45 +902,40 @@ package body Atree is
Set_Entity (New_Id, Empty);
end if;
-- This is the point at which we do the special processing for
-- the Syntax_Only flag being set:
-- Reset all Etype fields and Analyzed flags, because tree may
-- have been partly analyzed.
if Syntax_Only then
if Nkind (New_Id) in N_Has_Etype then
Set_Etype (New_Id, Empty);
end if;
-- Reset all Etype fields and Analyzed flags
Set_Analyzed (New_Id, False);
if Nkind (New_Id) in N_Has_Etype then
Set_Etype (New_Id, Empty);
end if;
-- Rather special case, if we have an expanded name, then change
-- it back into a selected component, so that the tree looks the
-- way it did coming out of the parser. This will change back
-- when we analyze the selected component node.
Set_Analyzed (New_Id, False);
if Nkind (New_Id) = N_Expanded_Name then
-- Rather special case, if we have an expanded name, then change
-- it back into a selected component, so that the tree looks the
-- way it did coming out of the parser. This will change back
-- when we analyze the selected component node.
-- The following code is a bit kludgy. It would be cleaner to
-- Add an entry Change_Expanded_Name_To_Selected_Component to
-- Sinfo.CN, but that's an earthquake, because it has the wrong
-- license, and Atree is used outside the compiler, e.g. in the
-- binder and in ASIS, so we don't want to add that dependency.
if Nkind (New_Id) = N_Expanded_Name then
-- Consequently we have no choice but to hold our noses and do
-- the change manually. At least we are Atree, so this odd use
-- of Atree.Unchecked_Access is at least all in the family.
-- The following code is a bit kludgy. It would be cleaner to
-- Add an entry Change_Expanded_Name_To_Selected_Component to
-- Sinfo.CN, but that's an earthquake, because it has the wrong
-- license, and Atree is used outside the compiler, e.g. in the
-- binder and in ASIS, so we don't want to add that dependency.
-- Change the node type
-- Consequently we have no choice but to hold our noses and do
-- the change manually. At least we are Atree, so this odd use
-- of Atree.Unchecked_Access is at least all in the family.
Atree.Unchecked_Access.Set_Nkind (New_Id, N_Selected_Component);
-- Change the node type
-- Clear the Chars field which is not present in a selected
-- component node, so we don't want a junk value around.
Atree.Unchecked_Access.Set_Nkind (New_Id, N_Selected_Component);
-- Clear the Chars field which is not present in a selected
-- component node, so we don't want a junk value around.
Set_Node1 (New_Id, Empty);
end if;
Set_Node1 (New_Id, Empty);
end if;
-- All done, return copied node

37
gcc/ada/atree.ads
View File

@ -494,9 +494,7 @@ package Atree is
-- is thus still attached to the tree. It is valid for Source to be Empty,
-- in which case Relocate_Node simply returns Empty as the result.
function Copy_Separate_Tree
(Source : Node_Id;
Syntax_Only : Boolean := False) return Node_Id;
function Copy_Separate_Tree (Source : Node_Id) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Separate_Tree copies
-- the entire syntactic subtree, including recursively any descendants
-- whose parent field references a copied node (descendants not linked to
@ -506,34 +504,11 @@ package Atree is
-- but has new entities with the same name. Most of the time this routine
-- is called on an unanalyzed tree, and no semantic information is copied.
-- However, to ensure that no entities are shared between the two when the
-- source is already analyzed, entity fields in the copy are zeroed out.
--
-- In addition, if Syntax_Only is set True, then when Copy_Separate_Tree
-- is applied Identical to Copy_Separate_Tree except that in the case of
-- applying it to an already analyzed tree, all Etype fields are reset,
-- and all Analyzed flags are set False. In addition, Expanded_Name
-- nodes are converted back into the original parser form (where they are
-- Selected_Components), so that renalysis does the right thing.
--
-- Note: it really seems like Copy_Separate_Tree could do these identical
-- steps unconditionally, and that nearly works, except for this one known
-- test case that fails:
--
-- 1. procedure III is
-- 2. procedure Proc2 is
-- 3. pragma Inline_Always (Proc2);
-- |
-- >>> argument of "INLINE_ALWAYS" must be entity in
-- current scope
--
-- 4. begin
-- 5. null;
-- 6. end Proc2;
-- 7. begin
-- 8. null;
-- 9. end III;
--
-- To be investigated ???
-- source is already analyzed, entity fields in the copy are zeroed out,
-- as well as Etype fields and the Analyzed flag.
-- In addition, Expanded_Name nodes are converted back into the original
-- parser form (where they are Selected_Components), so that renalysis does
-- the right thing.
function Copy_Separate_List (Source : List_Id) return List_Id;
-- Applies Copy_Separate_Tree to each element of the Source list, returning

10
gcc/ada/freeze.adb
View File

@ -3426,14 +3426,12 @@ package body Freeze is
-- Note on calls to Copy_Separate_Tree. The trees we are copying
-- here are fully analyzed, but we definitely want fully syntactic
-- unanalyzed trees in the body we construct, so that the analysis
-- generates the right visibility. So this is a case in which we
-- set Syntax_Only. See spec of Copy_Separate_Tree for details on
-- the use of this flag.
-- generates the right visibility.
-- Acquire copy of Inline pragma
Iprag :=
Copy_Separate_Tree (Import_Pragma (E), Syntax_Only => True);
Copy_Separate_Tree (Import_Pragma (E));
-- Fix up spec to be not imported any more
@ -3477,11 +3475,11 @@ package body Freeze is
Bod :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Separate_Tree (Spec, Syntax_Only => True),
Copy_Separate_Tree (Spec),
Declarations => New_List (
Make_Subprogram_Declaration (Loc,
Specification =>
Copy_Separate_Tree (Spec, Syntax_Only => True)),
Copy_Separate_Tree (Spec)),
Iprag),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,

7
gcc/ada/g-sercom-linux.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2012, AdaCore --
-- Copyright (C) 2007-2013, AdaCore --
-- --
-- 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- --
@ -132,7 +132,10 @@ package body GNAT.Serial_Communications is
procedure Raise_Error (Message : String; Error : Integer := Errno) is
begin
raise Serial_Error with Message & " (" & Integer'Image (Error) & ')';
raise Serial_Error with Message
& (if Error /= 0
then " (" & Errno_Message (Err => Error) & ')'
else "");
end Raise_Error;
----------

7
gcc/ada/g-sercom-mingw.adb
View File

@ -41,6 +41,8 @@ with System.OS_Constants;
with System.Win32; use System.Win32;
with System.Win32.Ext; use System.Win32.Ext;
with GNAT.OS_Lib;
package body GNAT.Serial_Communications is
package OSC renames System.OS_Constants;
@ -137,7 +139,10 @@ package body GNAT.Serial_Communications is
procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
begin
raise Serial_Error with Message & " (" & DWORD'Image (Error) & ')';
raise Serial_Error with Message
& (if Error /= 0
then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')'
else "");
end Raise_Error;
----------

15
gcc/ada/raise-gcc.c
View File

@ -84,8 +84,13 @@ extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
/* The known and handled exception classes. */
#ifdef __ARM_EABI_UNWINDER__
#define CXX_EXCEPTION_CLASS "GNUCC++"
#define GNAT_EXCEPTION_CLASS "GNU-Ada"
#else
#define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL
#define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL
#endif
/* Structure of a C++ exception, represented as a C structure... See
unwind-cxx.h for the full definition. */
@ -863,16 +868,10 @@ extern struct Exception_Data Non_Ada_Error;
/* Return true iff the exception class of EXCEPT is EC. */
static int
exception_class_eq (const _GNAT_Exception *except, unsigned long long ec)
exception_class_eq (const _GNAT_Exception *except, _Unwind_Exception_Class ec)
{
#ifdef __ARM_EABI_UNWINDER__
union {
char exception_class[8];
unsigned long long ec;
} u;
u.ec = ec;
return memcmp (except->common.exception_class, u.exception_class, 8) == 0;
return memcmp (except->common.exception_class, ec, 8) == 0;
#else
return except->common.exception_class == ec;
#endif

3
gcc/ada/s-os_lib.adb
View File

@ -932,7 +932,8 @@ package body System.OS_Lib is
declare
Val : Integer;
First : Integer;
Buf : String (1 .. 20);
Buf : String (1 .. 20);
-- Buffer large enough to hold image of largest Integer values
begin

9
gcc/ada/sem_ch6.adb
View File

@ -2352,6 +2352,15 @@ package body Sem_Ch6 is
Set_Has_Pragma_Inline_Always (Subp);
end if;
-- Prior to copying the subprogram body to create a template
-- for it for subsequent inlining, remove the pragma from
-- the current body so that the copy that will produce the
-- new body will start from a completely unanalyzed tree.
if Nkind (Parent (Prag)) = N_Subprogram_Body then
Rewrite (Prag, Make_Null_Statement (Sloc (Prag)));
end if;
Spec := Subp;
end;
end if;