+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.
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;
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,
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;
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;
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;
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;
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;
-- 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;
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;
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
begin
return Table;
end;
+
else
declare
Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
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;
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;
-- 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);
is
Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr;
+
begin
-- Save the offset to top field in the secondary dispatch table
-- 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;
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 =>
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);
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);
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
-
- -- Reset all Etype fields and Analyzed flags
-
- if Nkind (New_Id) in N_Has_Etype then
- Set_Etype (New_Id, Empty);
- 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
- -- 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.
+ -- 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.
- 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
- -- 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.
+ -- 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.
- -- 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.
+ -- 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.
- -- 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
- -- component node, so we don't want a junk value around.
+ -- 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
-- 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
-- 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
-- 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
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,
-- --
-- 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- --
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;
----------
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;
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;
----------
/* 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. */
/* 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
declare
Val : Integer;
First : Integer;
- Buf : String (1 .. 20);
+
+ Buf : String (1 .. 20);
-- Buffer large enough to hold image of largest Integer values
begin
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;
projects / thirdparty / gcc.git / commitdiff
