diff options
| author | Alexandre Oliva <oliva@adacore.com> | 2024-11-13 19:21:56 -0300 |
|---|---|---|
| committer | Marc Poulhiès <dkm@gcc.gnu.org> | 2025-01-03 16:39:12 +0100 |
| commit | fbe14f65eddd7f450079cff893a2ddc8fb454543 (patch) | |
| tree | 86e6db67e16308de32e6fee3feb85e03186e91bc /gcc | |
| parent | 758de5fed10a7c964bb06a143a3dc3c308721ddd (diff) | |
| download | gcc-fbe14f65eddd7f450079cff893a2ddc8fb454543.zip gcc-fbe14f65eddd7f450079cff893a2ddc8fb454543.tar.gz gcc-fbe14f65eddd7f450079cff893a2ddc8fb454543.tar.bz2 | |
ada: Handle C++ exception hierarchies
This patch introduces support for defining exceptions in Ada with
C++'s notion of exception type compatibility, such as handling
occurrences of derived types, and obtaining class-wide access to the
thrown/raised objects. As a bonus, it adds support for C++ dependent
(wrapped) exceptions, and introduces types and interfaces to match
C++'s std::type_info and std::exception.
Support for C++ exceptions with base-type matching, added to raise-gcc
by calling subprograms in Ada units, requires these units and their
dependencies to be linked into programs that link with raise-gcc.
gcc/ada/ChangeLog:
* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add g-cpp, g-cppstd,
and g-cstyin.
* doc/gnat_rm/interfacing_to_other_languages.rst (Interfacing to C++):
Document class-wide matching and new interfaces.
* exp_prag.adb (Expand_Pragma_Import_Or_Interface): Add class-wide
exception matching support with 'B' as language identifier.
* libgnat/a-exexpr.adb (Setup_Current_Excep): Add Id formal.
(Set_Foreign_Occurrence): Likewise.
(Propagate_GCC_Exception): Adjust.
(Set_Exception_Parameter): Likewise.
(Unhandled_Except_Handler): Likewise.
* libgnat/g-cpp.ads: New.
* libgnat/g-cppexc.adb (Raise_Cpp_Exception): Match 'B' lang id.
(Get_Object_Address): New.
(Get_Object): Rewrite.
(Get_Access_To_Object): New.
(Get_Access_To_Tagged_Object): New.
(Get_Type_Info): New.
(Convert_Caught_Object): New.
* libgnat/g-cppexc.ads (Get_Object_Address): New.
(Get_Object): Note the Cpp Convention requirement.
(Get_Access_To_Object): New.
(Get_Access_To_Tagged_Object): New.
(Get_Type_Info): New.
* libgnat/g-cppstd.adb: New.
* libgnat/g-cppstd.ads: New.
* libgnat/g-csclex.ads: New, unused.
* libgnat/g-cstyin.adb: New.
* libgnat/g-cstyin.ads: New.
* libgnat/g-excact.adb (Exception_Language): New.
(Is_Foreign_Exception): Rewrite.
* libgnat/g-excact.ads (Exception_Languages): New.
(Exception_Language): New.
* libgnat/s-stalib.ads (Lang): Document 'B'.
* raise-gcc.c (__gnat_setup_current_excep): Add Exception_Id formal.
(CXX_DEPENDENT_EXCEPTION_CLASS): New.
(cxx_type_info): New.
(__cxa_exception): Rename exceptionType to encompass PrimaryException.
(_GNAT_Exception): Drop wrapper.
(EID_For): Adjust.
(exception_class_eq): Likewise.
(__gnat_exception_language_is_cplusplus): New.
(__gnat_exception_language_is_ada): New.
(__gnat_convert_caught_object): Declare.
(__gnat_get_cxx_dependent_exception): New.
(__gnat_maybe_get_cxx_dependent_exception): New.
(__gnat_get_cxx_exception_type_info): New.
(__gnat_obtain_caught_object): New.
(is_handled_by): Adjust. [!CERT] Add eid formal, handle dependent
exceptions and base-type matches.
(get_action_description_for) [!CERT]: Add eid formal. Adjust.
(personality_body): Adjust.
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS) [!STAGE1]:
Add new g-cpp, g-cppstd, g-cstyin + preexisting g-cppexc
and i-cstrin.
* gnat-style.texi: Regenerate.
* gnat_rm.texi: Regenerate.
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/Makefile.rtl | 3 | ||||
| -rw-r--r-- | gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst | 163 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 10 | ||||
| -rw-r--r-- | gcc/ada/gnat-style.texi | 4 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 164 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-exexpr.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cpp.ads | 36 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cppexc.adb | 213 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cppexc.ads | 48 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cppstd.adb | 115 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cppstd.ads | 95 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-csclex.ads | 98 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cstyin.adb | 122 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-cstyin.ads | 141 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-excact.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-excact.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-stalib.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/raise-gcc.c | 250 |
19 files changed, 1550 insertions, 89 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 6379c84..cd112d3 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -419,6 +419,9 @@ GNATRTL_NONTASKING_OBJS= \ g-comlin$(objext) \ g-comver$(objext) \ g-crc32$(objext) \ + g-cpp$(objext) \ + g-cppstd$(objext) \ + g-cstyin$(objext) \ g-ctrl_c$(objext) \ g-curexc$(objext) \ g-debpoo$(objext) \ diff --git a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst index ad0be51..03cd330 100644 --- a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst +++ b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst @@ -121,7 +121,168 @@ It is also possible to import a C++ exception using the following syntax: The ``External_Name`` is the name of the C++ RTTI symbol. You can then -cover a specific C++ exception in an exception handler. +cover a specific C++ exception in an exception handler. If the string +ends with "'Class", as if referencing the Class attribute of the C++ +type, that enables "class-wide" type matching, i.e., instances of C++ +classes derived from the one denoted by the RTTI symbol, that would be +caught by C++ handlers for that type, will also be caught by Ada +handlers for ``Entity``. For non-class-wide RTTI symbols imported from +C++, only exact type matches will be handled. C++ rethrown (dependent) +exceptions are not distinguishable from the corresponding primary +exceptions: they are handled exactly as if the primary exception had +been raised. + +With imported exceptions, especially with base-type matching, a single +handled_sequence_of_statements may have exception handlers with +choices that cover the same C++ types in ways that GNAT cannot detect. +For example, C++ classes ``base`` and ``derived`` may be imported as +exceptions with base-type matching, but GNAT does not know that they +are related by inheritance, only the runtime will know it. Given: + +:: + + exception + when Derived_Exception => null; + when Base_Exception => null; + when others => null; + +the earliest handler that matches the type of the raised object will +be selected. If an instance of ``derived`` or a further derived type +is raised, the first handler will be used; if an instance of ``base`` +that is not an instance of ``derived`` is raised, the second handler +will be used; raised objects that are not instances of ``base`` will +be handled by the ``others`` handler. However, if the handlers were +reordered (``others`` must remain last), the ``Derived_Exception`` +handler would never be used, because ``Base_Exception`` would match +any instances of ``derived`` before ``Derived_Exception`` or +``others`` handlers were considered. Mixing exact-type and base-type +matching exceptions may also involve overlapping handlers that GNAT +will not reject: an exact-type ``Base_Only_Exception`` handler placed +before ``Base_Exception`` will handle instances of ``base``, whereas +instances of derived types will be handled by +``Base_Exception``. Swapping them will cause ``Base_Exception`` to +handle all instances of ``base`` and derived types, so that a +subsequent handler for ``Base_Only_Exception`` will never be selected. + +The C++ object associated with a C++ ``Exception_Occurrence`` may be +obtained by calling the ``GNAT.CPP_Exceptions.Get_Object_Address`` +function. There are convenience generic wrappers named ``Get_Object``, +``Get_Access_To_Object``, and ``Get_Access_To_Tagged_Object``, +parameterized on the expected Ada type. Note that, for exceptions +imported from C++, the address of the object is that of the subobject +of the type associated with the exception, which may have a different +address from that of the full object; for C++ exceptions handled by +``others`` handlers, however, the address of the full object is +returned. + +E.g., if the imported exception uses the RTTI symbol for the base +class, followed by "'Class", and the C++ code raises (throws) an +instance of a derived class, a handler for that imported exception +will catch this ``Exception_Occurrence``, and ``Get_Object_Address`` +will return the address of the base subobject of the raised derived +object; ``Get_Object``, ``Get_Access_To_Object`` and +``Get_Access_To_Tagged_Object`` only convert that address to the +parameterized type, so the specified type ought to be a type that +imports the C++ type whose RTTI symbol was named in the declared +exception, i.e., base, not derived or any other type. GNAT cannot +detect or report if a type is named that does not match the handler's +RTTI-specified type. + +For ``others`` handlers, and for exact type matches, the full object +is obtained. The ``Get_Type_Info`` function that takes an +``Exception_Occurrence`` argument can be used to verify the type of +the C++ object raised as an exception. The other ``Get_Type_Info`` +function, that takes an ``Exception_Id``, obtains the type expected by +the handler, and no such type exists for ``others`` handlers. +``GNAT.CPP.Std.Name`` can then convert the opaque +``GNAT.CPP.Std.Type_Info_Ptr`` access to ``std::type_info`` objects, +returned by either ``Get_Type_Info`` function, to a C++ mangled type +name. + +If an ``Exception_Occurrence`` was raised from C++, or following C++ +conventions, ``GNAT.Exception_Actions.Exception_Language`` will return +``EL_Cpp``, whether the exception handler is an imported C++ exception +or ``others``. ``GNAT.Exception_Actions.Is_Foreign_Exception`` returns +True for all of these, as well as for any case in which +``Exception_Language`` is not ``EL_Ada``. + +:: + + -- Given the following partial package specification: + + Base_Exception : exception; + pragma Import (Cpp, Base_Exception, "_ZTI4base'Class"); + -- Handle instances of base, and of subclasses. + + type Base is limited tagged record + [...] + end record; + pragma Import (Cpp, Base); + + type Derived is limited tagged record + [...] + end record; + pragma Import (Cpp, Derived); + + type Unrelated is access procedure (B : Boolean); + + function Get_Base_Obj_Acc is + new Get_Access_To_Tagged_Object (Base); + function Get_Derived_Obj_Acc is + new Get_Access_To_Tagged_Object (Derived); + function Get_Unrelated_Obj_Acc is + new Get_Access_To_Object (Unrelated); + + procedure Raise_Derived; + -- Raises an instance of derived (with a base subobject). + + + -- The comments next to each statement indicate the behavior of + -- the following pseudocode blocks: + + begin + Raise_Derived; + exception + when BEx : Base_Exception => + ?? := Is_Foreign_Exception (BEx); -- True + ?? := Exception_Language (BEx); -- EL_Cpp + ?? := Name (Get_Type_Info (BEx)); -- "7derived" + ?? := Name (Get_Type_Info (Exception_Identity (BEx))); -- "4base" + ?? := Get_Object_Address (BEx); -- base subobject in derived object + ?? := Get_Base_Obj_Acc (BEx): -- ditto, as access to Base + ?? := Get_Derived_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + ?? := Get_Unrelated_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + end; + + + begin + Raise_Derived; + exception + when BEx : others => + ?? := Is_Foreign_Exception (BEx); -- True + ?? := Exception_Language (BEx); -- EL_Cpp + ?? := Name (Get_Type_Info (BEx)); -- "7derived" + ?? := Get_Type_Info (Exception_Identity (BEx)); -- null + ?? := Get_Object_Address (BEx); -- full derived object + ?? := Get_Derived_Obj_Acc (BEx): -- ditto, as access to Derived + ?? := Get_Base_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + ?? := Get_Unrelated_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + end; + +The calls marked with ``NO ERROR DETECTED!`` will compile sucessfully, +even though the types specified in the specializations of the generic +function do not match the type of the exception object that the +function is expected to return. Mismatches between derived and base +types are particularly relevant because they will appear to work as +long as there isn't any offset between pointers to these types. This +may hold in many cases, but is subject to change with various possible +changes to the derived class. + +The ``GNAT.CPP.Std`` package offers interfaces corresponding to the +C++ standard type ``std::type_info``. Function ``To_Type_Info_Ptr`` +builds an opaque ``Type_Info_Ptr`` to reference a ``std::type_info`` +object at a given ``System.Address``. + .. _Interfacing_to_COBOL: diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 871a190..e94afb4 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -60,6 +60,8 @@ with Uintp; use Uintp; with Validsw; use Validsw; with Warnsw; use Warnsw; +with System.Case_Util; use System.Case_Util; + package body Exp_Prag is ----------------------- @@ -2157,24 +2159,73 @@ package body Exp_Prag is -- Import a C++ convention declare + procedure Check_Class_Suffix; + -- Check whether the External Name string designated by + -- Name, declared below, ends with "'class" and, if so, + -- set Lang_Id accordingly, and drop the suffix from Name + -- and from Rtti_Name. + Loc : constant Source_Ptr := Sloc (N); - Rtti_Name : constant Node_Id := Arg_N (N, 3); Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); + Lang_Id : Character := 'C'; + Rtti_Name : Node_Id := Arg_N (N, 3); + Name : String_Id := Strval (Get_Pragma_Arg (Rtti_Name)); Exdata : List_Id; Lang_Char : Node_Id; Foreign_Data : Node_Id; + ------------------------ + -- Check_Class_Suffix -- + ------------------------ + + procedure Check_Class_Suffix is + Attr : constant String := "'class"; + J : Nat := String_Length (Name); + begin + -- We can't end with "'class" if there's no room for it + + if J < Attr'Length then + return; + end if; + + -- Check that we end with "'class", ignoring case. + -- Return if we don't. + + for K in reverse 1 .. Attr'Length loop + if To_Lower (Get_Character (Get_String_Char (Name, J))) + /= Attr (K) + then + return; + end if; + J := J - 1; + end loop; + + -- Build a new string without the pseudo attribute. + -- Change Lang_Id to use base-type matching. + + Start_String; + for I in 1 .. J loop + Store_String_Char (Get_String_Char (Name, I)); + end loop; + Name := End_String; + Rtti_Name := Make_String_Literal (Sloc (Rtti_Name), + Strval => Name); + Lang_Id := 'B'; + end Check_Class_Suffix; + begin + Check_Class_Suffix; + Exdata := Component_Associations (Expression (Parent (Def_Id))); Lang_Char := Next (First (Exdata)); - -- Change the one-character language designator to 'C' + -- Change the one-character language designator to Lang_Id Rewrite (Expression (Lang_Char), Make_Character_Literal (Loc, Chars => Name_uC, - Char_Literal_Value => UI_From_CC (Get_Char_Code ('C')))); + Char_Literal_Value => UI_From_CC (Get_Char_Code (Lang_Id)))); Analyze (Expression (Lang_Char)); -- Change the value of Foreign_Data diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index f3009f1..1d8f097 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -513,6 +513,10 @@ GNAT_ADA_OBJS+= \ ada/libgnat/a-numeri.o \ ada/libgnat/ada.o \ ada/libgnat/g-byorma.o \ + ada/libgnat/g-cpp.o \ + ada/libgnat/g-cppexc.o \ + ada/libgnat/g-cppstd.o \ + ada/libgnat/g-cstyin.o \ ada/libgnat/g-heasor.o \ ada/libgnat/g-htable.o \ ada/libgnat/g-spchge.o \ @@ -520,6 +524,7 @@ GNAT_ADA_OBJS+= \ ada/libgnat/g-table.o \ ada/libgnat/g-u3spch.o \ ada/libgnat/i-c.o \ + ada/libgnat/i-cstrin.o \ ada/libgnat/interfac.o \ ada/libgnat/s-addope.o \ ada/libgnat/s-addima.o \ @@ -692,9 +697,14 @@ GNATBIND_OBJS += \ ada/libgnat/a-numeri.o \ ada/libgnat/ada.o \ ada/libgnat/g-byorma.o \ + ada/libgnat/g-cpp.o \ + ada/libgnat/g-cppexc.o \ + ada/libgnat/g-cppstd.o \ + ada/libgnat/g-cstyin.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ ada/libgnat/i-c.o \ + ada/libgnat/i-cstrin.o \ ada/libgnat/interfac.o \ ada/libgnat/s-addope.o \ ada/libgnat/s-assert.o \ diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index d0ba53a..dde6ec4 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -19,11 +19,11 @@ @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Oct 07, 2024 +GNAT Coding Style: A Guide for GNAT Developers , Jan 03, 2025 AdaCore -Copyright @copyright{} 2008-2024, Free Software Foundation +Copyright @copyright{} 2008-2025, Free Software Foundation @end quotation @end copying diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b7a26c1..baf549e 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Dec 12, 2024 +GNAT Reference Manual , Jan 03, 2025 AdaCore @@ -25877,7 +25877,167 @@ pragma Import (Cpp, @end example The @code{External_Name} is the name of the C++ RTTI symbol. You can then -cover a specific C++ exception in an exception handler. +cover a specific C++ exception in an exception handler. If the string +ends with “‘Class”, as if referencing the Class attribute of the C++ +type, that enables “class-wide” type matching, i.e., instances of C++ +classes derived from the one denoted by the RTTI symbol, that would be +caught by C++ handlers for that type, will also be caught by Ada +handlers for @code{Entity}. For non-class-wide RTTI symbols imported from +C++, only exact type matches will be handled. C++ rethrown (dependent) +exceptions are not distinguishable from the corresponding primary +exceptions: they are handled exactly as if the primary exception had +been raised. + +With imported exceptions, especially with base-type matching, a single +handled_sequence_of_statements may have exception handlers with +choices that cover the same C++ types in ways that GNAT cannot detect. +For example, C++ classes @code{base} and @code{derived} may be imported as +exceptions with base-type matching, but GNAT does not know that they +are related by inheritance, only the runtime will know it. Given: + +@example +exception + when Derived_Exception => null; + when Base_Exception => null; + when others => null; +@end example + +the earliest handler that matches the type of the raised object will +be selected. If an instance of @code{derived} or a further derived type +is raised, the first handler will be used; if an instance of @code{base} +that is not an instance of @code{derived} is raised, the second handler +will be used; raised objects that are not instances of @code{base} will +be handled by the @code{others} handler. However, if the handlers were +reordered (@code{others} must remain last), the @code{Derived_Exception} +handler would never be used, because @code{Base_Exception} would match +any instances of @code{derived} before @code{Derived_Exception} or +@code{others} handlers were considered. Mixing exact-type and base-type +matching exceptions may also involve overlapping handlers that GNAT +will not reject: an exact-type @code{Base_Only_Exception} handler placed +before @code{Base_Exception} will handle instances of @code{base}, whereas +instances of derived types will be handled by +@code{Base_Exception}. Swapping them will cause @code{Base_Exception} to +handle all instances of @code{base} and derived types, so that a +subsequent handler for @code{Base_Only_Exception} will never be selected. + +The C++ object associated with a C++ @code{Exception_Occurrence} may be +obtained by calling the @code{GNAT.CPP_Exceptions.Get_Object_Address} +function. There are convenience generic wrappers named @code{Get_Object}, +@code{Get_Access_To_Object}, and @code{Get_Access_To_Tagged_Object}, +parameterized on the expected Ada type. Note that, for exceptions +imported from C++, the address of the object is that of the subobject +of the type associated with the exception, which may have a different +address from that of the full object; for C++ exceptions handled by +@code{others} handlers, however, the address of the full object is +returned. + +E.g., if the imported exception uses the RTTI symbol for the base +class, followed by “‘Class”, and the C++ code raises (throws) an +instance of a derived class, a handler for that imported exception +will catch this @code{Exception_Occurrence}, and @code{Get_Object_Address} +will return the address of the base subobject of the raised derived +object; @code{Get_Object}, @code{Get_Access_To_Object} and +@code{Get_Access_To_Tagged_Object} only convert that address to the +parameterized type, so the specified type ought to be a type that +imports the C++ type whose RTTI symbol was named in the declared +exception, i.e., base, not derived or any other type. GNAT cannot +detect or report if a type is named that does not match the handler’s +RTTI-specified type. + +For @code{others} handlers, and for exact type matches, the full object +is obtained. The @code{Get_Type_Info} function that takes an +@code{Exception_Occurrence} argument can be used to verify the type of +the C++ object raised as an exception. The other @code{Get_Type_Info} +function, that takes an @code{Exception_Id}, obtains the type expected by +the handler, and no such type exists for @code{others} handlers. +@code{GNAT.CPP.Std.Name} can then convert the opaque +@code{GNAT.CPP.Std.Type_Info_Ptr} access to @code{std::type_info} objects, +returned by either @code{Get_Type_Info} function, to a C++ mangled type +name. + +If an @code{Exception_Occurrence} was raised from C++, or following C++ +conventions, @code{GNAT.Exception_Actions.Exception_Language} will return +@code{EL_Cpp}, whether the exception handler is an imported C++ exception +or @code{others}. @code{GNAT.Exception_Actions.Is_Foreign_Exception} returns +True for all of these, as well as for any case in which +@code{Exception_Language} is not @code{EL_Ada}. + +@example +-- Given the following partial package specification: + + Base_Exception : exception; + pragma Import (Cpp, Base_Exception, "_ZTI4base'Class"); + -- Handle instances of base, and of subclasses. + + type Base is limited tagged record + [...] + end record; + pragma Import (Cpp, Base); + + type Derived is limited tagged record + [...] + end record; + pragma Import (Cpp, Derived); + + type Unrelated is access procedure (B : Boolean); + + function Get_Base_Obj_Acc is + new Get_Access_To_Tagged_Object (Base); + function Get_Derived_Obj_Acc is + new Get_Access_To_Tagged_Object (Derived); + function Get_Unrelated_Obj_Acc is + new Get_Access_To_Object (Unrelated); + + procedure Raise_Derived; + -- Raises an instance of derived (with a base subobject). + + +-- The comments next to each statement indicate the behavior of +-- the following pseudocode blocks: + +begin + Raise_Derived; +exception + when BEx : Base_Exception => + ?? := Is_Foreign_Exception (BEx); -- True + ?? := Exception_Language (BEx); -- EL_Cpp + ?? := Name (Get_Type_Info (BEx)); -- "7derived" + ?? := Name (Get_Type_Info (Exception_Identity (BEx))); -- "4base" + ?? := Get_Object_Address (BEx); -- base subobject in derived object + ?? := Get_Base_Obj_Acc (BEx): -- ditto, as access to Base + ?? := Get_Derived_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + ?? := Get_Unrelated_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! +end; + + +begin + Raise_Derived; +exception + when BEx : others => + ?? := Is_Foreign_Exception (BEx); -- True + ?? := Exception_Language (BEx); -- EL_Cpp + ?? := Name (Get_Type_Info (BEx)); -- "7derived" + ?? := Get_Type_Info (Exception_Identity (BEx)); -- null + ?? := Get_Object_Address (BEx); -- full derived object + ?? := Get_Derived_Obj_Acc (BEx): -- ditto, as access to Derived + ?? := Get_Base_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! + ?? := Get_Unrelated_Obj_Acc (BEx): -- ditto, NO ERROR DETECTED! +end; +@end example + +The calls marked with @code{NO ERROR DETECTED!} will compile sucessfully, +even though the types specified in the specializations of the generic +function do not match the type of the exception object that the +function is expected to return. Mismatches between derived and base +types are particularly relevant because they will appear to work as +long as there isn’t any offset between pointers to these types. This +may hold in many cases, but is subject to change with various possible +changes to the derived class. + +The @code{GNAT.CPP.Std} package offers interfaces corresponding to the +C++ standard type @code{std::type_info}. Function @code{To_Type_Info_Ptr} +builds an opaque @code{Type_Info_Ptr} to reference a @code{std::type_info} +object at a given @code{System.Address}. @node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages @anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{418}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{419} diff --git a/gcc/ada/libgnat/a-exexpr.adb b/gcc/ada/libgnat/a-exexpr.adb index 0fe5227..f16e2a9 100644 --- a/gcc/ada/libgnat/a-exexpr.adb +++ b/gcc/ada/libgnat/a-exexpr.adb @@ -139,7 +139,8 @@ package body Exception_Propagation is function Setup_Current_Excep (GCC_Exception : not null GCC_Exception_Access; - Phase : Unwind_Action) return EOA; + Phase : Unwind_Action; + Id : Exception_Id) return EOA; pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); -- Acknowledge GCC_Exception as the current exception object being -- raised, which could be an Ada or a foreign exception object. Return @@ -195,10 +196,13 @@ package body Exception_Propagation is -- Called inserted by gigi to set the exception choice parameter from the -- gcc occurrence. - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); + procedure Set_Foreign_Occurrence + (Excep : EOA; + Mo : System.Address; + Id : Exception_Id := Foreign_Exception'Access); -- Utility routine to initialize occurrence Excep from a foreign exception -- whose machine occurrence is Mo. The message is empty, the backtrace - -- is empty too and the exception identity is Foreign_Exception. + -- is empty too and the exception identity is Id. -- Hooks called when entering/leaving an exception handler for a -- given occurrence. The calls are generated by gigi in @@ -354,10 +358,13 @@ package body Exception_Propagation is -- Set_Foreign_Occurrence -- ---------------------------- - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is + procedure Set_Foreign_Occurrence + (Excep : EOA; + Mo : System.Address; + Id : Exception_Id := Foreign_Exception'Access) is begin Excep.all := ( - Id => Foreign_Exception'Access, + Id => Id, Machine_Occurrence => Mo, Msg => <>, Msg_Length => 0, @@ -373,7 +380,8 @@ package body Exception_Propagation is function Setup_Current_Excep (GCC_Exception : not null GCC_Exception_Access; - Phase : Unwind_Action) return EOA + Phase : Unwind_Action; + Id : Exception_Id) return EOA is Excep : constant EOA := Get_Current_Excep.all; @@ -408,7 +416,11 @@ package body Exception_Propagation is -- an Ada occurrence info. Set the foreign data pointer in the -- Current Exception Buffer and return the address of the latter. - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + if Id = null then + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + else + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address, Id); + end if; return Excep; end if; @@ -589,7 +601,7 @@ package body Exception_Propagation is -- our personality routine. Excep : constant EOA := - Setup_Current_Excep (GCC_Exception, Phase => 0); + Setup_Current_Excep (GCC_Exception, Phase => 0, Id => null); begin -- Perform a standard raise first. If a regular handler is found, it @@ -653,9 +665,12 @@ package body Exception_Propagation is end; else - -- A default one + -- A default one. Take the Id from the exception object + -- created by Setup_Current_Excep. + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address, + Get_Current_Excep.all.Id); - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); end if; end Set_Exception_Parameter; @@ -668,7 +683,8 @@ package body Exception_Propagation is is Excep : EOA; begin - Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE); + Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE, + Id => null); Unhandled_Exception_Terminate (Excep); end Unhandled_Except_Handler; diff --git a/gcc/ada/libgnat/g-cpp.ads b/gcc/ada/libgnat/g-cpp.ads new file mode 100644 index 0000000..5b74d46 --- /dev/null +++ b/gcc/ada/libgnat/g-cpp.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package may provide an Ada interface for some C++ standard +-- entities in the global namespace. + +package GNAT.CPP is +end GNAT.CPP; diff --git a/gcc/ada/libgnat/g-cppexc.adb b/gcc/ada/libgnat/g-cppexc.adb index ddb2481..1102288 100644 --- a/gcc/ada/libgnat/g-cppexc.adb +++ b/gcc/ada/libgnat/g-cppexc.adb @@ -29,8 +29,7 @@ -- -- ------------------------------------------------------------------------------ -with System; -with System.Storage_Elements; +with System; use System; with Interfaces.C; use Interfaces.C; with Ada.Unchecked_Conversion; with System.Standard_Library; use System.Standard_Library; @@ -84,7 +83,7 @@ package body GNAT.CPP_Exceptions is begin -- Check the exception was imported from C++ - if Id_Data.Lang /= 'C' then + if Id_Data.Lang not in 'B' | 'C' then raise Constraint_Error; end if; @@ -101,39 +100,211 @@ package body GNAT.CPP_Exceptions is cxa_throw (Occ, Id_Data.Foreign_Data, System.Null_Address); end Raise_Cpp_Exception; + ------------------------ + -- Get_Object_Address -- + ------------------------ + + function Get_Object_Address + (X : Exception_Occurrence) return System.Address + is + Exception_Addr : constant Address := + Get_Exception_Machine_Occurrence (X); + -- Machine occurrence of X + + Object_Addr : Address; + -- Address of the raised object, after calling Convert + + Id : constant Exception_Id := Exception_Identity (X); + + Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); + -- Get a non-private view on the exception + + Success : Integer; + + procedure Convert (Success : out Integer; + Object_Addr : out Address; + Catch_Type : Address; + Convention : Character; + Unw_Except : Address); + pragma Import (C, Convert, "__gnat_obtain_caught_object"); + + begin + -- Check the machine occurrence exists + + if Exception_Addr = Null_Address then + raise Constraint_Error; + end if; + + if Id_Data.Lang not in 'A' .. 'C' then + raise Constraint_Error; + end if; + + Convert (Success, Object_Addr, + Id_Data.Foreign_Data, Id_Data.Lang, + Exception_Addr); + if Success = 0 then + raise Constraint_Error; + end if; + + return Object_Addr; + end Get_Object_Address; + ---------------- -- Get_Object -- ---------------- function Get_Object (X : Exception_Occurrence) return T is - use System; - use System.Storage_Elements; + Object_Addr : constant System.Address := Get_Object_Address (X); + -- Address of the raised object - Unwind_Exception_Size : Natural; - pragma Import (C, Unwind_Exception_Size, "__gnat_unwind_exception_size"); - -- Size in bytes of _Unwind_Exception + -- Import the object from the occurrence + Result : constant T; + pragma Import (Ada, Result); + for Result'Address use Object_Addr; + begin + return Result; + end Get_Object; + -------------------------- + -- Get_Access_To_Object -- + -------------------------- + + function Get_Access_To_Object (X : Exception_Occurrence) + return access T + is + Object_Addr : constant System.Address := Get_Object_Address (X); + -- Address of the raised object + + type T_Acc is access T; + + function To_T_Acc is + new Ada.Unchecked_Conversion (System.Address, T_Acc); + + -- Import the object from the occurrence + Result : constant T_Acc := To_T_Acc (Object_Addr); + begin + return Result; + end Get_Access_To_Object; + + --------------------------------- + -- Get_Access_To_Tagged_Object -- + --------------------------------- + + function Get_Access_To_Tagged_Object (X : Exception_Occurrence) + return access T'Class + is + Object_Addr : constant System.Address := Get_Object_Address (X); + -- Address of the raised object + + type T_Acc is access T'Class; + + function To_T_Acc is + new Ada.Unchecked_Conversion (System.Address, T_Acc); + + -- Import the object from the occurrence + Result : constant T_Acc := To_T_Acc (Object_Addr); + begin + return Result; + end Get_Access_To_Tagged_Object; + + ------------------- + -- Get_Type_Info -- + ------------------- + + function Get_Type_Info (Id : Exception_Id) return Type_Info_Ptr is + Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); + -- Get a non-private view on the exception + + Foreign_Exception : aliased Exception_Data; + pragma Import + (Ada, Foreign_Exception, "system__exceptions__foreign_exception"); + begin + if Id_Data.Lang not in 'B' | 'C' then + if Id_Data.Lang = 'A' + and then + Id_Data = Foreign_Exception'Unchecked_Access + then + return No_Type_Info; + end if; + raise Constraint_Error; + end if; + + return To_Type_Info_Ptr (Id_Data.Foreign_Data); + end Get_Type_Info; + + ------------------- + -- Get_Type_Info -- + ------------------- + + function Get_Type_Info (X : Exception_Occurrence) return Type_Info_Ptr is Exception_Addr : constant Address := Get_Exception_Machine_Occurrence (X); -- Machine occurrence of X - begin - -- Check the machine occurrence exists + function Get_MO_RTTI (MO : Address) return Type_Info_Ptr; + pragma Import (Cpp, Get_MO_RTTI, "__gnat_get_cxx_exception_type_info"); + TI : Type_Info_Ptr; + begin if Exception_Addr = Null_Address then raise Constraint_Error; end if; - declare - -- Import the object from the occurrence - Result : T; - pragma Import (Ada, Result); - for Result'Address use - Exception_Addr + Storage_Offset (Unwind_Exception_Size); - begin - -- And return it - return Result; - end; - end Get_Object; + if To_Exception_Data_Ptr (Exception_Identity (X)).Lang + not in 'A' .. 'C' + then + raise Constraint_Error; + end if; + + TI := Get_MO_RTTI (Exception_Addr); + + if TI = No_Type_Info then + raise Constraint_Error; + end if; + + return TI; + + 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-cppexc.ads b/gcc/ada/libgnat/g-cppexc.ads index d2a4356..bf263e3 100644 --- a/gcc/ada/libgnat/g-cppexc.ads +++ b/gcc/ada/libgnat/g-cppexc.ads @@ -31,7 +31,9 @@ -- This package provides an interface for raising and handling C++ exceptions +with System; with Ada.Exceptions; use Ada.Exceptions; +with GNAT.CPP.Std; use GNAT.CPP.Std; package GNAT.CPP_Exceptions is generic @@ -40,9 +42,51 @@ package GNAT.CPP_Exceptions is -- Raise a C++ exception identified by Id. Associate Value with this -- occurrence. Id must refer to an exception that has the Cpp convention. + function Get_Object_Address + (X : Exception_Occurrence) return System.Address; + -- Extract the address of the object associated with X. The + -- exception of the occurrence X must have a Cpp Convention. When + -- the exception handler catches a base type of the raised object, + -- the returned address is that of the base type part of the + -- object, the type explicitly expected by the handler. + generic type T is private; function Get_Object (X : Exception_Occurrence) return T; - -- Extract the object associated with X. The exception of the occurrence - -- X must have a Cpp Convention. + -- Extract the object associated with X. The exception of the + -- occurrence X must have a Cpp Convention. When the exception + -- handler catches a base type of the raised object, the returned + -- object is (a copy of) the base type portion of the object. + + generic + type T is limited private; + function Get_Access_To_Object (X : Exception_Occurrence) + return access T; + -- Extract the object associated with X. The exception of the + -- occurrence X must have a Cpp Convention. When the exception + -- handler catches a base type of the raised object, access is + -- returned to the base type part of the object, the type + -- explicitly expected by the handler. + + generic + type T is abstract tagged limited private; + function Get_Access_To_Tagged_Object (X : Exception_Occurrence) + return access T'Class; + -- Extract the object associated with X. The exception of the + -- occurrence X must have a Cpp Convention. When the exception + -- handler catches a base type of the raised object, access is + -- returned to the base type part of the object, the type + -- explicitly expected by the handler. + + function Get_Type_Info (X : Exception_Occurrence) return Type_Info_Ptr; + -- Obtain the type information of the full C++ object raised as X. + -- When the exception is caught using a base-type match exception, + -- this may be a derived class from that named for the exception. + + function Get_Type_Info (Id : Exception_Id) return Type_Info_Ptr; + -- Obtain the type information of a C++ exception type. This will + -- be the std::type_info object named in the exception + -- declaration, even if ID is taken from an exception occurrence + -- containing an object of a derived type. + end GNAT.CPP_Exceptions; diff --git a/gcc/ada/libgnat/g-cppstd.adb b/gcc/ada/libgnat/g-cppstd.adb new file mode 100644 index 0000000..000dd47 --- /dev/null +++ b/gcc/ada/libgnat/g-cppstd.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P . S T D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package may provide an Ada interface for some C++ standard +-- entities in the std namespace. + +with GNAT.CPP.Std.Type_Info; +with Ada.Unchecked_Conversion; + +package body GNAT.CPP.Std is + ---------------------- + -- To_Type_Info_Ptr -- + ---------------------- + + function To_Type_Info_Ptr (S : System.Address) return Type_Info_Ptr is + function Impl is + new Ada.Unchecked_Conversion (System.Address, Type_Info_Ptr); + begin + return Impl (S); + end To_Type_Info_Ptr; + + ------------ + -- Name -- + ------------ + + function Name (this : Type_Info_Ptr) + return String + is (this.all.Name); + + --------------- + -- Before --- + --------------- + + function Before (this, that : Type_Info_Ptr) + -- return Interfaces.C.Extensions.bool; + return Boolean + is (this.all.Before (that)); + + --------------- + -- Equals --- + --------------- + + function Equals (this, that : Type_Info_Ptr) + -- return Interfaces.C.Extensions.bool; + return Boolean + is (this.all.Equals (that)); + + -------------------- + -- Is_Pointer_P -- + -------------------- + + function Is_Pointer_P (this : Type_Info_Ptr) + return Interfaces.C.Extensions.bool + is (this.all.Is_Pointer_P); + + --------------------- + -- Is_Function_P -- + --------------------- + + function Is_Function_P (this : Type_Info_Ptr) + return Interfaces.C.Extensions.bool + is (this.all.Is_Function_P); + + ---------------- + -- Do_Catch --- + ---------------- + + function Do_Catch + (this : Type_Info_Ptr; + thrown_type : Type_Info_Ptr; + thrown_object : in out System.Address; + outer_count : Interfaces.C.unsigned) + return Interfaces.C.Extensions.bool + is (this.all.Do_Catch (thrown_type, thrown_object, outer_count)); + + ----------------- + -- Do_Upcast --- + ----------------- + + function Do_Upcast + (this : Type_Info_Ptr; + target : Type_Info_Ptr; + obj_ptr : in out System.Address) + return Interfaces.C.Extensions.bool + is (this.all.Do_Upcast (target, obj_ptr)); + +end GNAT.CPP.Std; diff --git a/gcc/ada/libgnat/g-cppstd.ads b/gcc/ada/libgnat/g-cppstd.ads new file mode 100644 index 0000000..63ef03e --- /dev/null +++ b/gcc/ada/libgnat/g-cppstd.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P . S T D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package may provide an Ada interface for some C++ standard +-- entities in the std namespace. + +limited private with GNAT.CPP.Std.Type_Info; +with System; use System; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Extensions; use Interfaces.C.Extensions; + +package GNAT.CPP.Std is + type Type_Info_Ptr is private; + -- This type stands for C++ std::type_info *. + + No_Type_Info : constant Type_Info_Ptr; + + function To_Type_Info_Ptr (S : System.Address) return Type_Info_Ptr; + -- Return an opaque Type_Info_Ptr referencing the std::type_info + -- object presumed to be at S. + + function Name (this : Type_Info_Ptr) + -- return Interfaces.C.Strings.chars_ptr; + return String; + -- Exposed std::type_info member function. + + function Before (this, that : Type_Info_Ptr) + -- return Interfaces.C.Extensions.bool; + return Boolean; + -- Exposed std::type_info member function. + + function Equals (this, that : Type_Info_Ptr) + -- return Interfaces.C.Extensions.bool; + return Boolean; + -- Exposed std::type_info member function. + + function Is_Pointer_P (this : Type_Info_Ptr) + return Interfaces.C.Extensions.bool; + -- Exposed std::type_info member function. + + function Is_Function_P (this : Type_Info_Ptr) + return Interfaces.C.Extensions.bool; + -- Exposed std::type_info member function. + + function Do_Catch + (this : Type_Info_Ptr; + thrown_type : Type_Info_Ptr; + thrown_object : in out System.Address; + outer_count : Interfaces.C.unsigned) + return Interfaces.C.Extensions.bool; + -- Exposed std::type_info member function. + + function Do_Upcast + (this : Type_Info_Ptr; + target : Type_Info_Ptr; + obj_ptr : in out System.Address) + return Interfaces.C.Extensions.bool; + -- Exposed std::type_info member function. + +private + + type Type_Info_Ptr is access constant Type_Info.type_info'Class; + pragma No_Strict_Aliasing (Type_Info_Ptr); + + No_Type_Info : constant Type_Info_Ptr := null; + +end GNAT.CPP.Std; diff --git a/gcc/ada/libgnat/g-csclex.ads b/gcc/ada/libgnat/g-csclex.ads new file mode 100644 index 0000000..fe640a2 --- /dev/null +++ b/gcc/ada/libgnat/g-csclex.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P . S T D . C L A S S _ E X C E P T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to C++'s std::exception objects + +with Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +-- with GNAT.CPP_Exceptions; use GNAT.CPP_Exceptions; + +-- ??? Should we expose, or even keep this unit? We can't run +-- constructors (they're inline), and destructors have to be declared +-- before the public methods because of their position in the virtual +-- method table, so they have to be public as well. It could be +-- unsafe to run them without running the constructors we can't get +-- at, so deriving from this type would be a challenge, though it +-- could be potentially useful for obscure cross-language exception +-- handling scenarios. Adding this unit to libgnat would require +-- libgnat.so to depend on libsupc++, if the exception declarations +-- were uncommented out. +private package GNAT.CPP.Std.Class_Exception is + type Class_Exception is abstract tagged limited record + null; + end record; + pragma Import (CPP, Class_Exception); + + -- Defined inline, no out-of-line version available. + -- function New_Class_Exception return Class_Exception; + -- pragma Cpp_Constructor (New_Class_Exception); + -- pragma Machine_Attribute (New_Class_Exception, "nothrow"); + pragma Warnings (Off, "CPP constructor required for type"); + + -- Allowing destruction is undesirable, but since these are in + -- the virtual method table, we have to declare them. + -- ??? Could we make them private somehow? + procedure Destructor (Ex : access Class_Exception); + pragma Import (CPP, Destructor, "_ZNSt9exceptionD1Ev"); + pragma Machine_Attribute (Destructor, "nothrow"); + procedure Delete_Destructor (Ex : access Class_Exception); + pragma Import (CPP, Delete_Destructor, "_ZNSt9exceptionD0Ev"); + pragma Machine_Attribute (Delete_Destructor, "nothrow"); + + function What (Ex : access constant Class_Exception) return chars_ptr; + pragma Import (CPP, What, "_ZNKSt9exception4whatEv"); + pragma Machine_Attribute (What, "nothrow"); + -- Obtain the C string stored in the std::exception object. + + function What (Ex : access constant Class_Exception'Class) return String is + (Value (What (Ex))); + -- Obtain the C string stored in the std::exception object, + -- converted to an Ada String. + + -- function Get_Class_Exception_From_Occurrence is + -- new Get_Access_To_Tagged_Object (Class_Exception); + -- Obtain access to Class_Exception'Class of an + -- Exception_Occurrence handled as Class_Exception_Only or + -- Class_Exception_Or_Derived, as defined in comments below. + -- Adding this to libgnat would cause libgnat.so to depend on + -- libsupc++. + + -- Class_Exception_Only : exception; + -- pragma Import (Cpp, Class_Exception_Only, + -- "_ZTISt9exception"); + -- Exception to catch std::exception exact matches only. + + -- Class_Exception_Or_Derived : exception; + -- pragma Import (Cpp, Class_Exception_Or_Derived, + -- "_ZTISt9exception'Class"); + -- Exception to catch std::exception or derived types. + +end GNAT.CPP.Std.Class_Exception; diff --git a/gcc/ada/libgnat/g-cstyin.adb b/gcc/ada/libgnat/g-cstyin.adb new file mode 100644 index 0000000..8036ed5 --- /dev/null +++ b/gcc/ada/libgnat/g-cstyin.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P . S T D . T Y P E _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +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 Name_Starts_With_Asterisk (this : access constant type_info'Class) + return Boolean; + + function Name_Past_Asterisk (this : access constant type_info'Class) + return chars_ptr; + + 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); + + function Name_Starts_With_Asterisk (this : access constant type_info'Class) + return Boolean is + A : constant Address := To_Address (this.Raw_Name); + C : aliased char; + for C'Address use A; + 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); + begin + if this.Name_Starts_With_Asterisk then + Increment (Addr); + end if; + + return To_chars_ptr (Addr); + end Name_Past_Asterisk; + + ------------ + -- Name -- + ------------ + + function Name (this : access constant type_info'Class) + return String + is (Value (this.Name_Past_Asterisk)); + + -------------- + -- Before -- + -------------- + + 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 + then + return this.Name < that.Name; + end if; + + return To_Address (this.Raw_Name) < To_Address (that.Raw_Name); + end Before; + + -------------- + -- Equals -- + -------------- + + function Equals (this, that : access constant type_info'Class) + return Boolean is + begin + if this = that then + return True; + end if; + + if this.Name_Starts_With_Asterisk then + return False; + end if; + + return this.Name = that.Name; + end Equals; + +end GNAT.CPP.Std.Type_Info; diff --git a/gcc/ada/libgnat/g-cstyin.ads b/gcc/ada/libgnat/g-cstyin.ads new file mode 100644 index 0000000..06ed958 --- /dev/null +++ b/gcc/ada/libgnat/g-cstyin.ads @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P . S T D . T Y P E _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to C++'s std::type_info objects + +with System; +with Interfaces.C; +with Interfaces.C.Extensions; +with Interfaces.C.Strings; + +-- This unit should be kept private. We can't run constructors +-- (they're inline), and destructors have to be declared before the +-- public methods because of their position in the virtual method +-- table, so they have to be public as well. It would be unsafe to +-- run them, since std::type_info objects are typically +-- statically-allocated. Without out-of-line constructors, deriving +-- from this type would be a challenge. However, there are some +-- select APIs that we wish to use for exception handling machinery, +-- and others that could be potentially useful in Ada/C++ programs, +-- that are exposed in GNAT.CPP.Std. +private package GNAT.CPP.Std.Type_Info is + type type_info is abstract tagged limited private; + pragma Import (CPP, type_info); + + pragma Warnings (Off, "CPP constructor required for type"); + + -- Defined inline, no out-of-line version available. + -- function Constructor (name : Interfaces.C.Strings.chars_ptr) + -- return type_info is abstract; + -- pragma Cpp_Constructor (Constructor, "_ZNSt9type_infoC1EPKc"); + + -- Allowing destruction is undesirable, but since these are in + -- the virtual method table, we have to declare them. + -- ??? Could we make them private somehow? + procedure Destructor (this : access type_info); + pragma Import (CPP, Destructor, "_ZNSt9type_infoD1Ev"); + pragma Machine_Attribute (Destructor, "nothrow"); + procedure Delete_Destructor (This : access type_info); + pragma Import (CPP, Delete_Destructor, "_ZNSt9type_InfoD0Ev"); + pragma Machine_Attribute (Delete_Destructor, "nothrow"); + + -- Defined inline, no out-of-line version available. + -- Reimplemented in Ada, using Ada types. + function Name (this : access constant type_info'Class) + -- return Interfaces.C.Strings.chars_ptr; + return String; + -- pragma Import (CPP, Name, "_ZNKSt9type_info4nameEv"); + pragma Machine_Attribute (Name, "nothrow"); + + -- Defined inline, no out-of-line version available. + -- Reimplemented in Ada, using Ada types. + function Before (this, that : access constant type_info'Class) + -- return Interfaces.C.Extensions.bool; + return Boolean; + -- pragma Import (CPP, Before, "_ZNKSt9type_info6beforeERKS_"); + pragma Machine_Attribute (Before, "nothrow"); + + -- Defined inline, no out-of-line version available. + -- Reimplemented in Ada, with an Ada interface. + function Equals (this, that : access constant type_info'Class) + -- return Interfaces.C.Extensions.bool; + return Boolean; + -- pragma Import (CPP, Equals, "_ZNKSt9type_infoeqERKS_"); + pragma Machine_Attribute (Equals, "nothrow"); + + -- function "/=" (this : access constant type_info'Class; + -- arg : access constant type_info'Class) + -- return Interfaces.C.Extensions.bool; + -- pragma Import (CPP, "/=", "_ZNKSt9type_infoneERKS_"); + -- pragma Machine_Attribute ("/=", "nothrow"); + + -- Defined inline, no out-of-line version available. + -- function Hash_Code (this : access constant type_info'Class) + -- return Interfaces.C.size_t; + -- pragma Import (CPP, Hash_Code, "_ZNKSt9type_info9hash_codeEv"); + -- pragma Machine_Attribute (Hash_Code, "nothrow"); + + function Is_Pointer_P (this : access constant type_info) + return Interfaces.C.Extensions.bool; + pragma Import (CPP, Is_Pointer_P, + "_ZNKSt9type_info14__is_pointer_pEv"); + + function Is_Function_P (this : access constant type_info) + return Interfaces.C.Extensions.bool; + pragma Import (CPP, Is_Function_P, + "_ZNKSt9type_info15__is_function_pEv"); + + function Do_Catch + (this : access constant type_info; + thrown_type : access constant type_info'Class; + thrown_object : in out System.Address; + outer_count : Interfaces.C.unsigned) + return Interfaces.C.Extensions.bool; + pragma Import (CPP, Do_Catch, + "_ZNKSt9type_info10__do_catchEPKS_PPvj"); + + function Do_Upcast + (this : access constant type_info; + target : access constant type_info'Class; + obj_ptr : in out System.Address) + return Interfaces.C.Extensions.bool; + pragma Import + (CPP, Do_Upcast, + "_ZNKSt9type_info11__do_upcastEPKN10" + & "__cxxabiv117__class_type_infoEPPv"); + +private + + type type_info is abstract tagged limited record + Raw_Name : Interfaces.C.Strings.chars_ptr; + end record; + +end GNAT.CPP.Std.Type_Info; diff --git a/gcc/ada/libgnat/g-excact.adb b/gcc/ada/libgnat/g-excact.adb index c442d79..b4065a1 100644 --- a/gcc/ada/libgnat/g-excact.adb +++ b/gcc/ada/libgnat/g-excact.adb @@ -34,6 +34,7 @@ with System; with System.Soft_Links; use System.Soft_Links; with System.Standard_Library; use System.Standard_Library; with System.Exception_Table; use System.Exception_Table; +with Interfaces.C; use Interfaces.C; package body GNAT.Exception_Actions is @@ -108,17 +109,78 @@ package body GNAT.Exception_Actions is procedure Core_Dump (Occurrence : Exception_Occurrence) is separate; + ------------------------ + -- Exception_Language -- + ------------------------ + + function Exception_Language + (E : Exception_Occurrence) + return Exception_Languages is + + Foreign_Exception : aliased Exception_Data; + pragma Import + (Ada, Foreign_Exception, "system__exceptions__foreign_exception"); + + function To_Exception_Data_Ptr is new + Ada.Unchecked_Conversion (Exception_Id, Exception_Data_Ptr); + + IdD : constant Exception_Data_Ptr + := To_Exception_Data_Ptr (Exception_Identity (E)); + Lang : constant Character := IdD.Lang; + + begin + if Lang in 'B' .. 'C' then + return EL_Cpp; + end if; + + if Lang /= 'A' then + return EL_Unknown; + end if; + + if IdD /= Foreign_Exception'Unchecked_Access then + return EL_Ada; + end if; + + declare + function Get_Exception_Machine_Occurrence + (E : Exception_Occurrence) return System.Address; + pragma Import (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + + function Exception_Language_Is_CPlusPlus + (E : System.Address) + return C_bool; + pragma Import (C, Exception_Language_Is_CPlusPlus, + "__gnat_exception_language_is_cplusplus"); + + function Exception_Language_Is_Ada + (E : System.Address) + return C_bool; + pragma Import (C, Exception_Language_Is_Ada, + "__gnat_exception_language_is_ada"); + + Occurrence : constant System.Address + := Get_Exception_Machine_Occurrence (E); + begin + if Exception_Language_Is_CPlusPlus (Occurrence) then + return EL_Cpp; + elsif Exception_Language_Is_Ada (Occurrence) then + -- This might some day indicate third-party Ada exceptions. + -- With GNAT exceptions, we should not reach this point. + return EL_Ada; + end if; + end; + + return EL_Unknown; + end Exception_Language; + -------------------------- -- Is_Foreign_Exception -- -------------------------- function Is_Foreign_Exception (E : Exception_Occurrence) return Boolean is - Foreign_Exception : aliased Exception_Data; - pragma Import - (Ada, Foreign_Exception, "system__exceptions__foreign_exception"); begin - return (To_Data (Exception_Identity (E)) - = Foreign_Exception'Unchecked_Access); + return Exception_Language (E) /= EL_Ada; end Is_Foreign_Exception; ---------------- diff --git a/gcc/ada/libgnat/g-excact.ads b/gcc/ada/libgnat/g-excact.ads index f042868..46fc993 100644 --- a/gcc/ada/libgnat/g-excact.ads +++ b/gcc/ada/libgnat/g-excact.ads @@ -91,6 +91,13 @@ package GNAT.Exception_Actions is -- Note: All non-predefined exceptions will return Null_Id for programs -- compiled with pragma Restrictions (No_Exception_Registration). + type Exception_Languages is (EL_Unknown, EL_Ada, EL_Cpp); + -- Return type for Exception_Language. + + function Exception_Language + (E : Exception_Occurrence) return Exception_Languages; + -- Return the language from which the exception originates. + function Is_Foreign_Exception (E : Exception_Occurrence) return Boolean; -- Tell whether the exception occurrence E represents a foreign exception, -- such as one raised in C++ and caught by a when others choice in Ada. diff --git a/gcc/ada/libgnat/s-stalib.ads b/gcc/ada/libgnat/s-stalib.ads index 7ab03d5..eb4f2db 100644 --- a/gcc/ada/libgnat/s-stalib.ads +++ b/gcc/ada/libgnat/s-stalib.ads @@ -105,7 +105,8 @@ package System.Standard_Library is Lang : aliased Character; -- A character indicating the language raising the exception. -- Set to "A" for exceptions defined by an Ada program. - -- Set to "C" for imported C++ exceptions. + -- Set to "B" for imported C++ exceptions with base type matching. + -- Set to "C" for imported C++ exceptions with exact type matching. Name_Length : aliased Natural; -- Length of fully expanded name of exception diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 7179f62..1ea2963 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -114,7 +114,7 @@ _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *); extern struct Exception_Occurrence * -__gnat_setup_current_excep (_Unwind_Exception *, _Unwind_Action); +__gnat_setup_current_excep (_Unwind_Exception *, _Unwind_Action, Exception_Id); extern void __gnat_unhandled_except_handler (_Unwind_Exception *); @@ -138,18 +138,27 @@ extern void __gnat_raise_abort (void) __attribute__ ((noreturn)); #ifdef __ARM_EABI_UNWINDER__ #define CXX_EXCEPTION_CLASS "GNUCC++" +#define CXX_DEPENDENT_EXCEPTION_CLASS "GNUCC++\x01" #define GNAT_EXCEPTION_CLASS "GNU-Ada" #else #define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL +#define CXX_DEPENDENT_EXCEPTION_CLASS 0x474e5543432b2b01ULL #define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL #endif +/* Opaque C struct that stands for C++ std::type_info. */ + +struct cxx_type_info; + /* Structure of a C++ exception, represented as a C structure... See unwind-cxx.h for the full definition. */ struct __cxa_exception { - void *exceptionType; + /* In primary exceptions, this is a struct cxx_type_info *; + in dependent exceptions, this is a struct __cxa_exception *. + ??? Could we use a union without the risk of any ABI problems? */ + void *exceptionTypeOrPrimaryException; void (*exceptionDestructor)(void *); void (*unexpectedHandler)(); @@ -530,18 +539,6 @@ db_phases (int phases) */ -/* This is an incomplete "proxy" of the structure of exception objects as - built by the GNAT runtime library. Accesses to other fields than the common - header are performed through subprogram calls to alleviate the need of an - exact counterpart here and potential alignment/size issues for the common - header. See a-exexpr.adb. */ - -typedef struct -{ - _Unwind_Exception common; - /* ABI header, maximally aligned. */ -} _GNAT_Exception; - /* The three constants below are specific ttype identifiers for special exception ids. Their type should match what a-exexpr exports. */ @@ -944,7 +941,8 @@ get_call_site_action_for (_Unwind_Ptr ip, extern bool Is_Handled_By_Others (Exception_Id eid); extern char Language_For (Exception_Id eid); extern void *Foreign_Data_For (Exception_Id eid); -extern Exception_Id EID_For (_GNAT_Exception *e); + +extern Exception_Id EID_For (_Unwind_Exception * e); #define Foreign_Exception system__exceptions__foreign_exception extern struct Exception_Data Foreign_Exception; @@ -952,21 +950,169 @@ extern struct Exception_Data Foreign_Exception; /* Return true iff the exception class of EXCEPT is EC. */ static int -exception_class_eq (const _GNAT_Exception *except, +exception_class_eq (const _Unwind_Exception *except, const _Unwind_Exception_Class ec) { #ifdef __ARM_EABI_UNWINDER__ - return memcmp (except->common.exception_class, ec, 8) == 0; + return memcmp (except->exception_class, ec, 8) == 0; #else - return except->common.exception_class == ec; + return except->exception_class == ec; #endif } +/* Return true iff the exception class in EXCEPT is a C++ exception. */ +bool +__gnat_exception_language_is_cplusplus (_Unwind_Exception *except) +{ + return (exception_class_eq (except, CXX_EXCEPTION_CLASS) + || exception_class_eq (except, CXX_DEPENDENT_EXCEPTION_CLASS)); +} + +/* Return true iff the exception class in EXCEPT is an Ada exception. */ +bool +__gnat_exception_language_is_ada (_Unwind_Exception *except) +{ + return (exception_class_eq (except, GNAT_EXCEPTION_CLASS)); +} + +/* Check whether *THROWN_PTR of EXCEPT_TYPEINFO is to be caught by a + CHOICE_TYPEINFO handler under LANG convention. + Implemented by GNAT.CPP_Exception.Convert_Caught_Object. */ + +extern bool __gnat_convert_caught_object (struct cxx_type_info *choice_typeinfo, + struct cxx_type_info *except_typeinfo, + void **thrown_ptr_p, char lang); + +/* Advance unconditionally to the primary exception from a dependent one + (std::rethrow_exception); see in + libstdc++-v3/libsupc++/unwind-cxx.h. */ + +static inline void +__gnat_get_cxx_dependent_exception (void **thrown_ptr_p) +{ + struct __cxa_exception *cxa_xcpt + = ((struct __cxa_exception *)*thrown_ptr_p - 1); + + *thrown_ptr_p = cxa_xcpt->exceptionTypeOrPrimaryException; +} + +/* Advance to the primary exception from a dependent one, + iff *THROWN_PTR_P corresponds to a dependent one. */ + +static inline void +__gnat_maybe_get_cxx_dependent_exception (void **thrown_ptr_p) +{ + _Unwind_Exception *propagated_exception + = ((_Unwind_Exception *)*thrown_ptr_p - 1); + + if (exception_class_eq (propagated_exception, + CXX_DEPENDENT_EXCEPTION_CLASS)) + __gnat_get_cxx_dependent_exception (thrown_ptr_p); +} + +/* Return the std::type_info* that denotes the type of the thrown + object. Return NULL if it's not a C++ exception. */ +struct cxx_type_info * +__gnat_get_cxx_exception_type_info (_Unwind_Exception *unwind_exception) +{ + void *thrown_ptr = unwind_exception + 1; + + __gnat_maybe_get_cxx_dependent_exception (&thrown_ptr); + + struct __cxa_exception *cxa_xcpt + = ((struct __cxa_exception *)thrown_ptr - 1); + + if (!exception_class_eq (&cxa_xcpt->unwindHeader, + CXX_EXCEPTION_CLASS)) + return NULL; + + struct cxx_type_info *except_typeinfo + = (struct cxx_type_info *)cxa_xcpt->exceptionTypeOrPrimaryException; + + return except_typeinfo; +} + +/* Convert the exception denoted by UNWIND_EXCEPTION to CHOICE_TYPE. + + If LANG is 'B', the type of the exception may be a derived type + that would be caught by CHOICE_TYPE in C++, otherwise the types + must be an exact match. + + If the type requirements are not met, set *SUCCESS_P to FALSE and + *THROWN_PTR_P to NULL. + + Otherwise, set *SUCCESS_P to TRUE and *THROWN_PTR_P to the + (sub)object of CHOICE_TYPE in the exception object. */ + +void +__gnat_obtain_caught_object (int *success_p, void **thrown_ptr_p, + struct cxx_type_info *choice_typeinfo, + char lang, + _Unwind_Exception *unwind_exception) +{ + void *thrown_ptr = unwind_exception + 1; + + /* Unwrap a dependent exception. */ + __gnat_maybe_get_cxx_dependent_exception (&thrown_ptr); + + bool success; + + switch (lang) + { + default: + success = false; + break; + + case 'A': + success = true; + break; + + case 'B': + case 'C': + { + struct __cxa_exception *cxa_xcpt + = ((struct __cxa_exception *)thrown_ptr - 1); + struct cxx_type_info *except_typeinfo + = (struct cxx_type_info *)cxa_xcpt->exceptionTypeOrPrimaryException; + + /* Adjust thrown_ptr, typed except_typeinfo, to point to the + choice_typeinfo subobject. */ + success = __gnat_convert_caught_object (choice_typeinfo, + except_typeinfo, + &thrown_ptr, + lang); + + break; + } + } + + /* Store the requested results. */ + if (success_p) + *success_p = success; + + if (thrown_ptr_p) + { + if (success) + *thrown_ptr_p = thrown_ptr; + else + *thrown_ptr_p = NULL; + } +} + /* Return how CHOICE matches PROPAGATED_EXCEPTION. */ static enum action_kind -is_handled_by (Exception_Id choice, _GNAT_Exception *propagated_exception) +is_handled_by (Exception_Id choice, +#ifndef CERT + Exception_Id *eid, +#endif + _Unwind_Exception *propagated_exception) { +#ifndef CERT + char lang; + bool primary; +#endif + /* All others choice match everything. */ if (choice == GNAT_ALL_OTHERS) return handler; @@ -999,21 +1145,31 @@ is_handled_by (Exception_Id choice, _GNAT_Exception *propagated_exception) return handler; #ifndef CERT - /* C++ exception occurrences. */ - if (exception_class_eq (propagated_exception, CXX_EXCEPTION_CLASS) - && Language_For (choice) == 'C') + /* C++ exception occurrences with exact (C) or base (B) type matching. */ + if (((primary = exception_class_eq (propagated_exception, + CXX_EXCEPTION_CLASS)) + || exception_class_eq (propagated_exception, + CXX_DEPENDENT_EXCEPTION_CLASS)) + && ((lang = Language_For (choice)) == 'C' || lang == 'B')) { - void *choice_typeinfo = Foreign_Data_For (choice); - void *except_typeinfo = - (((struct __cxa_exception *) - ((_Unwind_Exception *)propagated_exception + 1)) - 1) - ->exceptionType; - - /* Typeinfo are directly compared, which might not be correct if they - aren't merged. ??? We should call the == operator if this module is - compiled in C++. */ - if (choice_typeinfo == except_typeinfo) - return handler; + struct cxx_type_info *choice_typeinfo + = ((struct cxx_type_info *)Foreign_Data_For (choice)); + void *thrown_ptr = (propagated_exception + 1); + + if (!primary) + __gnat_get_cxx_dependent_exception (&thrown_ptr); + + struct __cxa_exception *cxa_xcpt + = ((struct __cxa_exception *)thrown_ptr - 1); + struct cxx_type_info *except_typeinfo + = (struct cxx_type_info *)cxa_xcpt->exceptionTypeOrPrimaryException; + + if (__gnat_convert_caught_object (choice_typeinfo, except_typeinfo, + &thrown_ptr, lang)) + { + *eid = (Exception_Id) choice; + return handler; + } } #endif @@ -1027,11 +1183,12 @@ static void get_action_description_for (_Unwind_Ptr ip, _Unwind_Exception *uw_exception, _Unwind_Action uw_phase, +#ifndef CERT + Exception_Id *eid, +#endif region_descriptor *region, action_descriptor *action) { - _GNAT_Exception *gnat_exception = (_GNAT_Exception *) uw_exception; - /* Search the call site table first, which may get us a landing pad as well as the head of an action record list. */ get_call_site_action_for (ip, region, action); @@ -1101,9 +1258,13 @@ get_action_description_for (_Unwind_Ptr ip, Exception_Id choice = (Exception_Id) get_ttype_entry_for (region, ar_filter); - act = is_handled_by (choice, gnat_exception); - if (act != nothing) - { + act = is_handled_by (choice, +#ifndef CERT + eid, +#endif + uw_exception); + if (act != nothing) + { action->kind = act; action->ttype_filter = ar_filter; return; @@ -1209,6 +1370,9 @@ personality_body (_Unwind_Action uw_phases, region_descriptor region; action_descriptor action; _Unwind_Ptr ip; +#ifndef CERT + Exception_Id eid = NULL; +#endif /* Debug traces. */ db_indent (DB_INDENT_RESET); @@ -1230,7 +1394,11 @@ personality_body (_Unwind_Action uw_phases, /* Search the call-site and action-record tables for the action associated with this IP. */ - get_action_description_for (ip, uw_exception, uw_phases, ®ion, &action); + get_action_description_for (ip, uw_exception, uw_phases, +#ifndef CERT + &eid, +#endif + ®ion, &action); db_action_for (&action, ip); /* Whatever the phase, if there is nothing relevant in this frame, @@ -1267,7 +1435,7 @@ personality_body (_Unwind_Action uw_phases, the Ada occurrence pointer to use. */ struct Exception_Occurrence *excep - = __gnat_setup_current_excep (uw_exception, uw_phases); + = __gnat_setup_current_excep (uw_exception, uw_phases, eid); if (action.kind == unhandler) __gnat_notify_unhandled_exception (excep); @@ -1291,7 +1459,7 @@ personality_body (_Unwind_Action uw_phases, /* Write current exception so that it can be retrieved from Ada. It was already done during phase 1, but one or several exceptions may have been raised in cleanup handlers in between. */ - __gnat_setup_current_excep (uw_exception, uw_phases); + __gnat_setup_current_excep (uw_exception, uw_phases, eid); #endif return _URC_INSTALL_CONTEXT; |