From: Alexandre Oliva <ol...@adacore.com>
The initial C++ base-type exception interoperation support change
brought all of GNAT.CPP* along with raise-gcc, because of
[__gnat_]Convert_Caught_Object. Move that private but pragma-exported
function to GNAT.CPP.Std.Type_Info, so that it can rely on the C++
virtual/dispatch calls that justified the introduction of the Ada
wrapper type, to avoid emulating virtual calls in C or bringing in a
dependency on the C++ compiler and runtime.
Drop the CharPtr package instantiation, that brought a huge amount of
unnecessary code, and use string and storage primitives instead, using
the strcmp builtin directly for the C string compares.
Move the conversion to Ada String in Name to the wrapper interface in
GNAT.CPP.Std, adjusting the private internal type to shave off a few
more bytes from the only unit that raise-gcc will still need.
Finally, disable heap finalization for Type_Info_Ptr, to avoid
dragging in all of the finalization code. Thank to Eric Botcazou for
the suggestion.
gcc/ada/ChangeLog:
* libgnat/g-cppexc.adb (Convert_Caught_Object): Move...
* libgnat/g-cstyin.adb (Convert_Caught_Object): ... here.
Use object call notation.
(strcmp): New.
(Char_Arr, CharPtr, Char_Pointer, To_chars_ptr): Drop. Do not
import Interfaces.C.Pointers.
(To_Pointer): Convert from System.Address.
(Name_Starts_With_Asterisk): Rename local variable.
(Name_Past_Asterisk): Rewrite with System.Address and strcmp.
Import System.Storage_Elements.
(Equals): Use strcmp.
(Before): Fix logic error. Use strcmp.
(Name): Move conversion to String...
* libgnat/g-cppstd.adb (Name): ... here. Import
Interfaces.C.Strings.
* libgnat/g-cppstd.ads (Type_Info_Ptr): Disable heap
finalization.
* libgnat/g-cstyin.ads (Name): Change return type.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/g-cppexc.adb | 40 ------------------
gcc/ada/libgnat/g-cppstd.adb | 3 +-
gcc/ada/libgnat/g-cppstd.ads | 4 +-
gcc/ada/libgnat/g-cstyin.adb | 80 ++++++++++++++++++++++++++----------
gcc/ada/libgnat/g-cstyin.ads | 2 +-
5 files changed, 65 insertions(+), 64 deletions(-)
diff --git a/gcc/ada/libgnat/g-cppexc.adb b/gcc/ada/libgnat/g-cppexc.adb
index 11022880670..bad748fdfe3 100644
--- a/gcc/ada/libgnat/g-cppexc.adb
+++ b/gcc/ada/libgnat/g-cppexc.adb
@@ -267,44 +267,4 @@ package body GNAT.CPP_Exceptions is
end Get_Type_Info;
- function Convert_Caught_Object (Choice, Except : Type_Info_Ptr;
- Thrown : in out Address;
- Lang : Character)
- return Interfaces.C.C_bool;
- pragma Export (Cpp, Convert_Caught_Object, "__gnat_convert_caught_object");
- -- Convert the exception object at Thrown, under Lang convention,
- -- from type Except to type Choice, adjusting Thrown as needed and
- -- returning True, or returning False in case the conversion fails.
-
- ---------------------------
- -- Convert_Caught_Object --
- ---------------------------
-
- function Convert_Caught_Object (Choice, Except : Type_Info_Ptr;
- Thrown : in out Address;
- Lang : Character)
- return Interfaces.C.C_bool is
- begin
- if Equals (Choice, Except) then
- return C_bool'(True);
- end if;
-
- if Lang = 'B' then
- if Is_Pointer_P (Except) then
- declare
- Thrown_Indirect : Address;
- for Thrown_Indirect'Address use Thrown;
- begin
- Thrown := Thrown_Indirect;
- end;
- end if;
-
- if Do_Catch (Choice, Except, Thrown, 1) then
- return C_bool'(True);
- end if;
- end if;
-
- return C_bool'(False);
- end Convert_Caught_Object;
-
end GNAT.CPP_Exceptions;
diff --git a/gcc/ada/libgnat/g-cppstd.adb b/gcc/ada/libgnat/g-cppstd.adb
index 000dd474c5c..8cb64edaffe 100644
--- a/gcc/ada/libgnat/g-cppstd.adb
+++ b/gcc/ada/libgnat/g-cppstd.adb
@@ -34,6 +34,7 @@
with GNAT.CPP.Std.Type_Info;
with Ada.Unchecked_Conversion;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
package body GNAT.CPP.Std is
----------------------
@@ -53,7 +54,7 @@ package body GNAT.CPP.Std is
function Name (this : Type_Info_Ptr)
return String
- is (this.all.Name);
+ is (Value (this.all.Name));
---------------
-- Before ---
diff --git a/gcc/ada/libgnat/g-cppstd.ads b/gcc/ada/libgnat/g-cppstd.ads
index 63ef03e43dd..be8907c4f77 100644
--- a/gcc/ada/libgnat/g-cppstd.ads
+++ b/gcc/ada/libgnat/g-cppstd.ads
@@ -50,7 +50,8 @@ package GNAT.CPP.Std is
function Name (this : Type_Info_Ptr)
-- return Interfaces.C.Strings.chars_ptr;
return String;
- -- Exposed std::type_info member function.
+ -- Exposed std::type_info member function. ??? Would it ever be
+ -- desirable to get direct access to the internal chars_ptr?
function Before (this, that : Type_Info_Ptr)
-- return Interfaces.C.Extensions.bool;
@@ -89,6 +90,7 @@ private
type Type_Info_Ptr is access constant Type_Info.type_info'Class;
pragma No_Strict_Aliasing (Type_Info_Ptr);
+ pragma No_Heap_Finalization (Type_Info_Ptr);
No_Type_Info : constant Type_Info_Ptr := null;
diff --git a/gcc/ada/libgnat/g-cstyin.adb b/gcc/ada/libgnat/g-cstyin.adb
index 8036ed52762..b194f7f62b7 100644
--- a/gcc/ada/libgnat/g-cstyin.adb
+++ b/gcc/ada/libgnat/g-cstyin.adb
@@ -30,14 +30,17 @@
------------------------------------------------------------------------------
with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
with Interfaces.C; use Interfaces.C;
-with Interfaces.C.Pointers;
with Interfaces.C.Extensions; use Interfaces.C.Extensions;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with Ada.Unchecked_Conversion;
package body GNAT.CPP.Std.Type_Info is
+ function strcmp (L, R : chars_ptr) return Interfaces.C.int;
+ pragma Import (Intrinsic, strcmp, "__builtin_strcmp");
+
function Name_Starts_With_Asterisk (this : access constant type_info'Class)
return Boolean;
@@ -46,35 +49,27 @@ package body GNAT.CPP.Std.Type_Info is
function To_Address is
new Ada.Unchecked_Conversion (chars_ptr, System.Address);
-
- type Char_Arr is array (Natural range <>) of aliased char;
- package CharPtr is
- new Interfaces.C.Pointers (Natural, char, Char_Arr, nul);
- type Char_Pointer is new CharPtr.Pointer;
-
function To_Pointer is
- new Ada.Unchecked_Conversion (chars_ptr, Char_Pointer);
- function To_chars_ptr is
- new Ada.Unchecked_Conversion (Char_Pointer, chars_ptr);
+ new Ada.Unchecked_Conversion (System.Address, chars_ptr);
function Name_Starts_With_Asterisk (this : access constant type_info'Class)
return Boolean is
- A : constant Address := To_Address (this.Raw_Name);
+ Addr : constant System.Address := To_Address (this.Raw_Name);
C : aliased char;
- for C'Address use A;
+ for C'Address use Addr;
begin
return C = '*';
end Name_Starts_With_Asterisk;
function Name_Past_Asterisk (this : access constant type_info'Class)
return chars_ptr is
- Addr : Char_Pointer := To_Pointer (this.Raw_Name);
+ Addr : System.Address := To_Address (this.Raw_Name);
begin
if this.Name_Starts_With_Asterisk then
- Increment (Addr);
+ Addr := Addr + Storage_Offset (1);
end if;
- return To_chars_ptr (Addr);
+ return To_Pointer (Addr);
end Name_Past_Asterisk;
------------
@@ -82,8 +77,8 @@ package body GNAT.CPP.Std.Type_Info is
------------
function Name (this : access constant type_info'Class)
- return String
- is (Value (this.Name_Past_Asterisk));
+ return chars_ptr
+ is (this.Name_Past_Asterisk);
--------------
-- Before --
@@ -92,10 +87,10 @@ package body GNAT.CPP.Std.Type_Info is
function Before (this, that : access constant type_info'Class)
return Boolean is
begin
- if this.Name_Starts_With_Asterisk
- or else that.Name_Starts_With_Asterisk
+ if not this.Name_Starts_With_Asterisk
+ or else not that.Name_Starts_With_Asterisk
then
- return this.Name < that.Name;
+ return strcmp (this.Raw_Name, that.Raw_Name) < 0;
end if;
return To_Address (this.Raw_Name) < To_Address (that.Raw_Name);
@@ -116,7 +111,50 @@ package body GNAT.CPP.Std.Type_Info is
return False;
end if;
- return this.Name = that.Name;
+ return strcmp (this.Raw_Name, that.Raw_Name) = 0;
end Equals;
+ function Convert_Caught_Object (Choice, Except : access type_info'Class;
+ Thrown : in out Address;
+ Lang : Character)
+ return Interfaces.C.C_bool;
+ pragma Export (Cpp, Convert_Caught_Object, "__gnat_convert_caught_object");
+ -- Convert the exception object at Thrown, under Lang convention,
+ -- from type Except to type Choice, adjusting Thrown as needed and
+ -- returning True, or returning False in case the conversion
+ -- fails. This is called from raise-gcc, and it is placed here
+ -- rather than in GNAT.CPP_Exceptions to avoid dragging all that
+ -- in when the program doesn't use C++ exceptions.
+
+ ---------------------------
+ -- Convert_Caught_Object --
+ ---------------------------
+
+ function Convert_Caught_Object (Choice, Except : access type_info'Class;
+ Thrown : in out Address;
+ Lang : Character)
+ return Interfaces.C.C_bool is
+ begin
+ if Choice.Equals (Except) then
+ return C_bool'(True);
+ end if;
+
+ if Lang = 'B' then
+ if Except.Is_Pointer_P then
+ declare
+ Thrown_Indirect : Address;
+ for Thrown_Indirect'Address use Thrown;
+ begin
+ Thrown := Thrown_Indirect;
+ end;
+ end if;
+
+ if Choice.Do_Catch (Except, Thrown, 1) then
+ return C_bool'(True);
+ end if;
+ end if;
+
+ return C_bool'(False);
+ end Convert_Caught_Object;
+
end GNAT.CPP.Std.Type_Info;
diff --git a/gcc/ada/libgnat/g-cstyin.ads b/gcc/ada/libgnat/g-cstyin.ads
index 06ed9588d53..37dad4544f4 100644
--- a/gcc/ada/libgnat/g-cstyin.ads
+++ b/gcc/ada/libgnat/g-cstyin.ads
@@ -71,7 +71,7 @@ private package GNAT.CPP.Std.Type_Info is
-- Reimplemented in Ada, using Ada types.
function Name (this : access constant type_info'Class)
-- return Interfaces.C.Strings.chars_ptr;
- return String;
+ return Interfaces.C.Strings.chars_ptr;
-- pragma Import (CPP, Name, "_ZNKSt9type_info4nameEv");
pragma Machine_Attribute (Name, "nothrow");
--
2.43.0
