------------------------------------------------------------------------------
--                                                                          --
--                         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-2025, 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 System.Storage_Elements; use System.Storage_Elements;
with Interfaces.C; use Interfaces.C;
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;

   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);
   function To_Pointer is
      new Ada.Unchecked_Conversion (System.Address, chars_ptr);

   function Name_Starts_With_Asterisk (this : access constant type_info'Class)
                                       return Boolean is
      Addr : constant System.Address := To_Address (this.Raw_Name);
      C : aliased char;
      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 : System.Address := To_Address (this.Raw_Name);
   begin
      if this.Name_Starts_With_Asterisk then
         Addr := Addr + Storage_Offset (1);
      end if;

      return To_Pointer (Addr);
   end Name_Past_Asterisk;

   ------------
   --  Name  --
   ------------

   function Name (this : access constant type_info'Class)
                  return chars_ptr
   is (this.Name_Past_Asterisk);

   --------------
   --  Before  --
   --------------

   function Before (this, that : access constant type_info'Class)
                    return       Boolean is
   begin
      if not this.Name_Starts_With_Asterisk
        or else not that.Name_Starts_With_Asterisk
      then
         return strcmp (this.Raw_Name, that.Raw_Name) < 0;
      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 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;