home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / i-cpp.adb < prev    next >
Text File  |  2000-07-19  |  11KB  |  338 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUN-TIME COMPONENTS                         --
  4. --                                                                          --
  5. --                       I N T E R F A C E S . C P P                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.18 $
  10. --                                                                          --
  11. --          Copyright (C) 1992-2000, Free Software Foundation, Inc.         --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Ada.Tags;                use Ada.Tags;
  37. with Interfaces.C;            use Interfaces.C;
  38. with System;                  use System;
  39. with System.Storage_Elements; use System.Storage_Elements;
  40. with Unchecked_Conversion;
  41.  
  42. package body Interfaces.CPP is
  43.  
  44.    subtype Cstring is String (Positive);
  45.    type Cstring_Ptr is access all Cstring;
  46.    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  47.    pragma Suppress_Initialization (Tag_Table);
  48.  
  49.    type Type_Specific_Data is record
  50.       Idepth        : Natural;
  51.       Expanded_Name : Cstring_Ptr;
  52.       External_Tag  : Cstring_Ptr;
  53.       HT_Link       : Tag;
  54.       Ancestor_Tags : Tag_Table (Natural);
  55.    end record;
  56.  
  57.    type Vtable_Entry is record
  58.      Pfn    : System.Address;
  59.    end record;
  60.  
  61.    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
  62.    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  63.  
  64.    type VTable is record
  65.       Unused1   : C.short;
  66.       Unused2   : C.short;
  67.       TSD       : Type_Specific_Data_Ptr;
  68.       Prims_Ptr : Vtable_Entry_Array (Positive);
  69.    end record;
  70.  
  71.    --------------------------------------------------------
  72.    -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
  73.    --------------------------------------------------------
  74.  
  75.    function To_Type_Specific_Data_Ptr is
  76.      new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
  77.  
  78.    function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
  79.    function To_Address is
  80.      new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
  81.  
  82.    function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
  83.    function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
  84.  
  85.    ---------------------------------------------
  86.    -- Unchecked Conversions for String Fields --
  87.    ---------------------------------------------
  88.  
  89.    function To_Cstring_Ptr is
  90.      new Unchecked_Conversion (Address, Cstring_Ptr);
  91.  
  92.    function To_Address is
  93.      new Unchecked_Conversion (Cstring_Ptr, Address);
  94.  
  95.    -----------------------
  96.    -- Local Subprograms --
  97.    -----------------------
  98.  
  99.    function Length (Str : Cstring_Ptr) return Natural;
  100.    --  Length of string represented by the given pointer (treating the
  101.    --  string as a C-style string, which is Nul terminated).
  102.  
  103.    --------------------
  104.    -- Displaced_This --
  105.    --------------------
  106.  
  107.    function Displaced_This
  108.     (Current_This : System.Address;
  109.      Vptr         : Vtable_Ptr;
  110.      Position     : Positive)
  111.      return         System.Address
  112.    is
  113.    begin
  114.       return Current_This;
  115. --        + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
  116.    end Displaced_This;
  117.  
  118.    -----------------------
  119.    -- CPP_CW_Membership --
  120.    -----------------------
  121.  
  122.    function CPP_CW_Membership
  123.      (Obj_Tag : Vtable_Ptr;
  124.       Typ_Tag : Vtable_Ptr)
  125.       return Boolean
  126.    is
  127.       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
  128.    begin
  129.       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
  130.    end CPP_CW_Membership;
  131.  
  132.    ---------------------------
  133.    -- CPP_Get_Expanded_Name --
  134.    ---------------------------
  135.  
  136.    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
  137.    begin
  138.       return To_Address (T.TSD.Expanded_Name);
  139.    end CPP_Get_Expanded_Name;
  140.  
  141.    --------------------------
  142.    -- CPP_Get_External_Tag --
  143.    --------------------------
  144.  
  145.    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
  146.    begin
  147.       return To_Address (T.TSD.External_Tag);
  148.    end CPP_Get_External_Tag;
  149.  
  150.    -------------------------------
  151.    -- CPP_Get_Inheritance_Depth --
  152.    -------------------------------
  153.  
  154.    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
  155.    begin
  156.       return T.TSD.Idepth;
  157.    end CPP_Get_Inheritance_Depth;
  158.  
  159.    -------------------------
  160.    -- CPP_Get_Prim_Op_Address --
  161.    -------------------------
  162.  
  163.    function CPP_Get_Prim_Op_Address
  164.      (T        : Vtable_Ptr;
  165.       Position : Positive)
  166.       return Address is
  167.    begin
  168.       return T.Prims_Ptr (Position).Pfn;
  169.    end CPP_Get_Prim_Op_Address;
  170.  
  171.    -------------------------------
  172.    -- CPP_Get_Remotely_Callable --
  173.    -------------------------------
  174.  
  175.    function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
  176.    begin
  177.       return True;
  178.    end CPP_Get_Remotely_Callable;
  179.  
  180.    -----------------
  181.    -- CPP_Get_TSD --
  182.    -----------------
  183.  
  184.    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
  185.    begin
  186.       return To_Address (T.TSD);
  187.    end CPP_Get_TSD;
  188.  
  189.    --------------------
  190.    -- CPP_Inherit_DT --
  191.    --------------------
  192.  
  193.    procedure CPP_Inherit_DT
  194.     (Old_T   : Vtable_Ptr;
  195.      New_T   : Vtable_Ptr;
  196.      Entry_Count : Natural)
  197.    is
  198.    begin
  199.       if Old_T /= null then
  200.          New_T.Prims_Ptr (1 .. Entry_Count)
  201.            := Old_T.Prims_Ptr (1 .. Entry_Count);
  202.       end if;
  203.    end CPP_Inherit_DT;
  204.  
  205.    ---------------------
  206.    -- CPP_Inherit_TSD --
  207.    ---------------------
  208.  
  209.    procedure CPP_Inherit_TSD
  210.      (Old_TSD : Address;
  211.       New_Tag : Vtable_Ptr)
  212.    is
  213.       TSD : constant Type_Specific_Data_Ptr
  214.         := To_Type_Specific_Data_Ptr (Old_TSD);
  215.  
  216.       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
  217.  
  218.    begin
  219.       if TSD /= null then
  220.          New_TSD.Idepth := TSD.Idepth + 1;
  221.          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
  222.            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
  223.       else
  224.          New_TSD.Idepth := 0;
  225.       end if;
  226.  
  227.       New_TSD.Ancestor_Tags (0) := New_Tag;
  228.    end CPP_Inherit_TSD;
  229.  
  230.    ---------------------------
  231.    -- CPP_Set_Expanded_Name --
  232.    ---------------------------
  233.  
  234.    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
  235.    begin
  236.       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
  237.    end CPP_Set_Expanded_Name;
  238.  
  239.    --------------------------
  240.    -- CPP_Set_External_Tag --
  241.    --------------------------
  242.  
  243.    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
  244.    begin
  245.       T.TSD.External_Tag := To_Cstring_Ptr (Value);
  246.    end CPP_Set_External_Tag;
  247.  
  248.    -------------------------------
  249.    -- CPP_Set_Inheritance_Depth --
  250.    -------------------------------
  251.  
  252.    procedure CPP_Set_Inheritance_Depth
  253.      (T     : Vtable_Ptr;
  254.       Value : Natural)
  255.    is
  256.    begin
  257.       T.TSD.Idepth := Value;
  258.    end CPP_Set_Inheritance_Depth;
  259.  
  260.    -----------------------------
  261.    -- CPP_Set_Prim_Op_Address --
  262.    -----------------------------
  263.  
  264.    procedure CPP_Set_Prim_Op_Address
  265.      (T        : Vtable_Ptr;
  266.       Position : Positive;
  267.       Value    : Address)
  268.    is
  269.    begin
  270.       T.Prims_Ptr (Position).Pfn := Value;
  271.    end CPP_Set_Prim_Op_Address;
  272.  
  273.    -------------------------------
  274.    -- CPP_Set_Remotely_Callable --
  275.    -------------------------------
  276.  
  277.    procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
  278.    begin
  279.       null;
  280.    end CPP_Set_Remotely_Callable;
  281.  
  282.    -----------------
  283.    -- CPP_Set_TSD --
  284.    -----------------
  285.  
  286.    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
  287.    begin
  288.       T.TSD := To_Type_Specific_Data_Ptr (Value);
  289.    end CPP_Set_TSD;
  290.  
  291.    -------------------
  292.    -- Expanded_Name --
  293.    -------------------
  294.  
  295.    function Expanded_Name (T : Vtable_Ptr) return String is
  296.       Result : Cstring_Ptr := T.TSD.Expanded_Name;
  297.  
  298.    begin
  299.       return Result (1 .. Length (Result));
  300.    end Expanded_Name;
  301.  
  302.    ------------------
  303.    -- External_Tag --
  304.    ------------------
  305.  
  306.    function External_Tag (T : Vtable_Ptr) return String is
  307.       Result : Cstring_Ptr := T.TSD.External_Tag;
  308.  
  309.    begin
  310.       return Result (1 .. Length (Result));
  311.    end External_Tag;
  312.  
  313.    ------------
  314.    -- Length --
  315.    ------------
  316.  
  317.    function Length (Str : Cstring_Ptr) return Natural is
  318.       Len : Integer := 1;
  319.  
  320.    begin
  321.       while Str (Len) /= ASCII.Nul loop
  322.          Len := Len + 1;
  323.       end loop;
  324.  
  325.       return Len - 1;
  326.    end Length;
  327.  
  328.    procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
  329.    begin
  330.       null;
  331.    end CPP_Set_RC_Offset;
  332.  
  333.    function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
  334.    begin
  335.       return 0;
  336.    end CPP_Get_RC_Offset;
  337. end Interfaces.CPP;
  338.