Skip to content

R
riscv-gcc-1
Commit 158d55fa by Arnaud Charlet
Options

[multiple changes] 

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
parent 5c20e503
Showing with 117 additions and 110 deletions
gcc/ada/ChangeLog
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> 2014-02-24 Thomas Quinot <quinot@adacore.com>
* s-os_lib.adb (Errno_Message): Do not depend on Integer'Image. * s-os_lib.adb (Errno_Message): Do not depend on Integer'Image.
......
gcc/ada/a-tags.adb
...@@ -31,6 +31,7 @@ ...@@ -31,6 +31,7 @@
with Ada.Exceptions; with Ada.Exceptions;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with System.HTable; with System.HTable;
with System.Storage_Elements; use System.Storage_Elements; with System.Storage_Elements; use System.Storage_Elements;
with System.WCh_Con; use System.WCh_Con; with System.WCh_Con; use System.WCh_Con;
...@@ -58,7 +59,8 @@ package body Ada.Tags is ...@@ -58,7 +59,8 @@ package body Ada.Tags is
function Length (Str : Cstring_Ptr) return Natural; function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string -- 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; function OSD (T : Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
...@@ -179,7 +181,7 @@ package body Ada.Tags is ...@@ -179,7 +181,7 @@ package body Ada.Tags is
function OSD (T : Tag) return Object_Specific_Data_Ptr is function OSD (T : Tag) return Object_Specific_Data_Ptr is
OSD_Ptr : constant Addr_Ptr := 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 begin
return To_Object_Specific_Data_Ptr (OSD_Ptr.all); return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
end OSD; end OSD;
...@@ -190,9 +192,9 @@ package body Ada.Tags is ...@@ -190,9 +192,9 @@ package body Ada.Tags is
function SSD (T : Tag) return Select_Specific_Data_Ptr is function SSD (T : Tag) return Select_Specific_Data_Ptr is
TSD_Ptr : constant Addr_Ptr := 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 := TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all); To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin begin
return TSD.SSD; return TSD.SSD;
end SSD; end SSD;
...@@ -241,8 +243,9 @@ package body Ada.Tags is ...@@ -241,8 +243,9 @@ package body Ada.Tags is
function Equal (A, B : System.Address) return Boolean is function Equal (A, B : System.Address) return Boolean is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1; J : Integer;
begin begin
J := 1;
loop loop
if Str1 (J) /= Str2 (J) then if Str1 (J) /= Str2 (J) then
return False; return False;
...@@ -260,9 +263,9 @@ package body Ada.Tags is ...@@ -260,9 +263,9 @@ package body Ada.Tags is
function Get_HT_Link (T : Tag) return Tag is function Get_HT_Link (T : Tag) return Tag is
TSD_Ptr : constant Addr_Ptr := 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 := TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all); To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin begin
return TSD.HT_Link.all; return TSD.HT_Link.all;
end Get_HT_Link; end Get_HT_Link;
...@@ -285,9 +288,9 @@ package body Ada.Tags is ...@@ -285,9 +288,9 @@ package body Ada.Tags is
procedure Set_HT_Link (T : Tag; Next : Tag) is procedure Set_HT_Link (T : Tag; Next : Tag) is
TSD_Ptr : constant Addr_Ptr := 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 := TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all); To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin begin
TSD.HT_Link.all := Next; TSD.HT_Link.all := Next;
end Set_HT_Link; end Set_HT_Link;
...@@ -357,10 +360,7 @@ package body Ada.Tags is ...@@ -357,10 +360,7 @@ package body Ada.Tags is
-- Displace -- -- Displace --
-------------- --------------
function Displace function Displace (This : System.Address; T : Tag) return System.Address is
(This : System.Address;
T : Tag) return System.Address
is
Iface_Table : Interface_Data_Ptr; Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address; Obj_Base : System.Address;
Obj_DT : Dispatch_Table_Ptr; Obj_DT : Dispatch_Table_Ptr;
...@@ -418,7 +418,7 @@ package body Ada.Tags is ...@@ -418,7 +418,7 @@ package body Ada.Tags is
function DT (T : Tag) return Dispatch_Table_Ptr is function DT (T : Tag) return Dispatch_Table_Ptr is
Offset : constant SSE.Storage_Offset := Offset : constant SSE.Storage_Offset :=
To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; To_Dispatch_Table_Ptr (T).Prims_Ptr'Position;
begin begin
return To_Dispatch_Table_Ptr (To_Address (T) - Offset); return To_Dispatch_Table_Ptr (To_Address (T) - Offset);
end DT; end DT;
...@@ -561,9 +561,9 @@ package body Ada.Tags is ...@@ -561,9 +561,9 @@ package body Ada.Tags is
function Interface_Ancestor_Tags (T : Tag) return Tag_Array is function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
TSD_Ptr : constant Addr_Ptr := 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 := 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; Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table;
begin begin
...@@ -573,6 +573,7 @@ package body Ada.Tags is ...@@ -573,6 +573,7 @@ package body Ada.Tags is
begin begin
return Table; return Table;
end; end;
else else
declare declare
Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
...@@ -605,13 +606,13 @@ package body Ada.Tags is ...@@ -605,13 +606,13 @@ package body Ada.Tags is
if External'Length > Internal_Tag_Header'Length if External'Length > Internal_Tag_Header'Length
and then and then
External (External'First .. External (External'First ..
External'First + Internal_Tag_Header'Length - 1) External'First + Internal_Tag_Header'Length - 1) =
= Internal_Tag_Header Internal_Tag_Header
then then
declare declare
Addr_First : constant Natural := Addr_First : constant Natural :=
External'First + Internal_Tag_Header'Length; External'First + Internal_Tag_Header'Length;
Addr_Last : Natural; Addr_Last : Natural;
Addr : Integer_Address; Addr : Integer_Address;
...@@ -783,9 +784,9 @@ package body Ada.Tags is ...@@ -783,9 +784,9 @@ package body Ada.Tags is
function Needs_Finalization (T : Tag) return Boolean is function Needs_Finalization (T : Tag) return Boolean is
TSD_Ptr : constant Addr_Ptr := 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 := TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all); To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin begin
return TSD.Needs_Finalization; return TSD.Needs_Finalization;
end Needs_Finalization; end Needs_Finalization;
...@@ -803,9 +804,9 @@ package body Ada.Tags is ...@@ -803,9 +804,9 @@ package body Ada.Tags is
-- ancestor tags. -- ancestor tags.
TSD_Ptr : constant Addr_Ptr := 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 := 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 -- Pointer to the TSD
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
...@@ -961,6 +962,7 @@ package body Ada.Tags is ...@@ -961,6 +962,7 @@ package body Ada.Tags is
is is
Sec_Base : System.Address; Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr; Sec_DT : Dispatch_Table_Ptr;
begin begin
-- Save the offset to top field in the secondary dispatch table -- Save the offset to top field in the secondary dispatch table
......
gcc/ada/atree.adb
...@@ -772,9 +772,7 @@ package body Atree is ...@@ -772,9 +772,7 @@ package body Atree is
-- Copy_Separate_Tree -- -- Copy_Separate_Tree --
------------------------ ------------------------
function Copy_Separate_Tree function Copy_Separate_Tree (Source : Node_Id) return Node_Id
(Source : Node_Id;
Syntax_Only : Boolean := False) return Node_Id
is is
New_Id : Node_Id; New_Id : Node_Id;
...@@ -796,9 +794,7 @@ package body Atree is ...@@ -796,9 +794,7 @@ package body Atree is
New_Ent : Entity_Id; New_Ent : Entity_Id;
begin begin
-- Build appropriate node. Note that in this case, we do not need to -- Build appropriate node.
-- do any special casing for Syntax_Only, since the new node has no
-- Etype set, and is always unanalyzed.
case N_Entity (Nkind (E)) is case N_Entity (Nkind (E)) is
when N_Defining_Identifier => when N_Defining_Identifier =>
...@@ -835,7 +831,7 @@ package body Atree is ...@@ -835,7 +831,7 @@ package body Atree is
if Has_Extension (E) then if Has_Extension (E) then
Append (Copy_Entity (E), NL); Append (Copy_Entity (E), NL);
else else
Append (Copy_Separate_Tree (E, Syntax_Only), NL); Append (Copy_Separate_Tree (E), NL);
end if; end if;
Next (E); Next (E);
...@@ -855,7 +851,7 @@ package body Atree is ...@@ -855,7 +851,7 @@ package body Atree is
begin begin
if Field in Node_Range then if Field in Node_Range then
New_N := 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 if Parent (Node_Id (Field)) = Source then
Set_Parent (Node_Id (New_N), New_Id); Set_Parent (Node_Id (New_N), New_Id);
...@@ -906,45 +902,40 @@ package body Atree is ...@@ -906,45 +902,40 @@ package body Atree is
Set_Entity (New_Id, Empty); Set_Entity (New_Id, Empty);
end if; end if;
-- This is the point at which we do the special processing for -- Reset all Etype fields and Analyzed flags, because tree may
-- the Syntax_Only flag being set: -- have been partly analyzed.
if Syntax_Only then if Nkind (New_Id) in N_Has_Etype then
Set_Etype (New_Id, Empty);
-- Reset all Etype fields and Analyzed flags end if;
if Nkind (New_Id) in N_Has_Etype then
Set_Etype (New_Id, Empty);
end if;
Set_Analyzed (New_Id, False); Set_Analyzed (New_Id, False);
-- Rather special case, if we have an expanded name, then change -- Rather special case, if we have an expanded name, then change
-- it back into a selected component, so that the tree looks the -- it back into a selected component, so that the tree looks the
-- way it did coming out of the parser. This will change back -- way it did coming out of the parser. This will change back
-- when we analyze the selected component node. -- when we analyze the selected component node.
if Nkind (New_Id) = N_Expanded_Name then if Nkind (New_Id) = N_Expanded_Name then
-- The following code is a bit kludgy. It would be cleaner to -- The following code is a bit kludgy. It would be cleaner to
-- Add an entry Change_Expanded_Name_To_Selected_Component to -- Add an entry Change_Expanded_Name_To_Selected_Component to
-- Sinfo.CN, but that's an earthquake, because it has the wrong -- Sinfo.CN, but that's an earthquake, because it has the wrong
-- license, and Atree is used outside the compiler, e.g. in the -- 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. -- binder and in ASIS, so we don't want to add that dependency.
-- Consequently we have no choice but to hold our noses and do -- Consequently we have no choice but to hold our noses and do
-- the change manually. At least we are Atree, so this odd use -- the change manually. At least we are Atree, so this odd use
-- of Atree.Unchecked_Access is at least all in the family. -- of Atree.Unchecked_Access is at least all in the family.
-- Change the node type -- Change the node type
Atree.Unchecked_Access.Set_Nkind (New_Id, N_Selected_Component); Atree.Unchecked_Access.Set_Nkind (New_Id, N_Selected_Component);
-- Clear the Chars field which is not present in a selected -- Clear the Chars field which is not present in a selected
-- component node, so we don't want a junk value around. -- component node, so we don't want a junk value around.
Set_Node1 (New_Id, Empty); Set_Node1 (New_Id, Empty);
end if;
end if; end if;
-- All done, return copied node -- All done, return copied node
......
gcc/ada/atree.ads
...@@ -494,9 +494,7 @@ package Atree is ...@@ -494,9 +494,7 @@ package Atree is
-- is thus still attached to the tree. It is valid for Source to be Empty, -- 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. -- in which case Relocate_Node simply returns Empty as the result.
function Copy_Separate_Tree function Copy_Separate_Tree (Source : Node_Id) return Node_Id;
(Source : Node_Id;
Syntax_Only : Boolean := False) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Separate_Tree copies -- Given a node that is the root of a subtree, Copy_Separate_Tree copies
-- the entire syntactic subtree, including recursively any descendants -- the entire syntactic subtree, including recursively any descendants
-- whose parent field references a copied node (descendants not linked to -- whose parent field references a copied node (descendants not linked to
...@@ -506,34 +504,11 @@ package Atree is ...@@ -506,34 +504,11 @@ package Atree is
-- but has new entities with the same name. Most of the time this routine -- 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. -- 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 -- 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. -- source is already analyzed, entity fields in the copy are zeroed out,
-- -- as well as Etype fields and the Analyzed flag.
-- In addition, if Syntax_Only is set True, then when Copy_Separate_Tree -- In addition, Expanded_Name nodes are converted back into the original
-- is applied Identical to Copy_Separate_Tree except that in the case of -- parser form (where they are Selected_Components), so that renalysis does
-- applying it to an already analyzed tree, all Etype fields are reset, -- the right thing.
-- 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 ???
function Copy_Separate_List (Source : List_Id) return List_Id; function Copy_Separate_List (Source : List_Id) return List_Id;
-- Applies Copy_Separate_Tree to each element of the Source list, returning -- Applies Copy_Separate_Tree to each element of the Source list, returning
......
gcc/ada/freeze.adb
...@@ -3426,14 +3426,12 @@ package body Freeze is ...@@ -3426,14 +3426,12 @@ package body Freeze is
-- Note on calls to Copy_Separate_Tree. The trees we are copying -- Note on calls to Copy_Separate_Tree. The trees we are copying
-- here are fully analyzed, but we definitely want fully syntactic -- here are fully analyzed, but we definitely want fully syntactic
-- unanalyzed trees in the body we construct, so that the analysis -- unanalyzed trees in the body we construct, so that the analysis
-- generates the right visibility. So this is a case in which we -- generates the right visibility.
-- set Syntax_Only. See spec of Copy_Separate_Tree for details on
-- the use of this flag.
-- Acquire copy of Inline pragma -- Acquire copy of Inline pragma
Iprag := 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 -- Fix up spec to be not imported any more
...@@ -3477,11 +3475,11 @@ package body Freeze is ...@@ -3477,11 +3475,11 @@ package body Freeze is
Bod := Bod :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Copy_Separate_Tree (Spec, Syntax_Only => True), Copy_Separate_Tree (Spec),
Declarations => New_List ( Declarations => New_List (
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Copy_Separate_Tree (Spec, Syntax_Only => True)), Copy_Separate_Tree (Spec)),
Iprag), Iprag),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
......
gcc/ada/g-sercom-linux.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -132,7 +132,10 @@ package body GNAT.Serial_Communications is ...@@ -132,7 +132,10 @@ package body GNAT.Serial_Communications is
procedure Raise_Error (Message : String; Error : Integer := Errno) is procedure Raise_Error (Message : String; Error : Integer := Errno) is
begin 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; end Raise_Error;
---------- ----------
......
gcc/ada/g-sercom-mingw.adb
...@@ -41,6 +41,8 @@ with System.OS_Constants; ...@@ -41,6 +41,8 @@ with System.OS_Constants;
with System.Win32; use System.Win32; with System.Win32; use System.Win32;
with System.Win32.Ext; use System.Win32.Ext; with System.Win32.Ext; use System.Win32.Ext;
with GNAT.OS_Lib;
package body GNAT.Serial_Communications is package body GNAT.Serial_Communications is
package OSC renames System.OS_Constants; package OSC renames System.OS_Constants;
...@@ -137,7 +139,10 @@ package body GNAT.Serial_Communications is ...@@ -137,7 +139,10 @@ package body GNAT.Serial_Communications is
procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
begin 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; end Raise_Error;
---------- ----------
......
gcc/ada/raise-gcc.c
...@@ -84,8 +84,13 @@ extern void __gnat_unhandled_except_handler (_Unwind_Exception *); ...@@ -84,8 +84,13 @@ extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
/* The known and handled exception classes. */ /* 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 CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL
#define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL #define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL
#endif
/* Structure of a C++ exception, represented as a C structure... See /* Structure of a C++ exception, represented as a C structure... See
unwind-cxx.h for the full definition. */ unwind-cxx.h for the full definition. */
...@@ -863,16 +868,10 @@ extern struct Exception_Data Non_Ada_Error; ...@@ -863,16 +868,10 @@ extern struct Exception_Data Non_Ada_Error;
/* Return true iff the exception class of EXCEPT is EC. */ /* Return true iff the exception class of EXCEPT is EC. */
static int 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__ #ifdef __ARM_EABI_UNWINDER__
union { return memcmp (except->common.exception_class, ec, 8) == 0;
char exception_class[8];
unsigned long long ec;
} u;
u.ec = ec;
return memcmp (except->common.exception_class, u.exception_class, 8) == 0;
#else #else
return except->common.exception_class == ec; return except->common.exception_class == ec;
#endif #endif
......
gcc/ada/s-os_lib.adb
...@@ -932,7 +932,8 @@ package body System.OS_Lib is ...@@ -932,7 +932,8 @@ package body System.OS_Lib is
declare declare
Val : Integer; Val : Integer;
First : Integer; First : Integer;
Buf : String (1 .. 20);
Buf : String (1 .. 20);
-- Buffer large enough to hold image of largest Integer values -- Buffer large enough to hold image of largest Integer values
begin begin
......
gcc/ada/sem_ch6.adb
...@@ -2352,6 +2352,15 @@ package body Sem_Ch6 is ...@@ -2352,6 +2352,15 @@ package body Sem_Ch6 is
Set_Has_Pragma_Inline_Always (Subp); Set_Has_Pragma_Inline_Always (Subp);
end if; 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; Spec := Subp;
end; end;
end if; end if;
......
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