home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / exp_disp.adb < prev    next >
Text File  |  1996-09-28  |  28KB  |  767 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             E X P _ D I S P                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.20 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  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, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Checks;   use Checks;
  27. with Einfo;    use Einfo;
  28. with Elists;   use Elists;
  29. with Errout;   use Errout;
  30. with Exp_TSS;  use Exp_TSS;
  31. with Exp_Util; use Exp_Util;
  32. with Expander; use Expander;
  33. with Itypes;   use Itypes;
  34. with Nlists;   use Nlists;
  35. with Nmake;    use Nmake;
  36. with Rtsfind;  use Rtsfind;
  37. with Sem;      use Sem;
  38. with Sem_Disp; use Sem_Disp;
  39. with Sem_Res;  use Sem_Res;
  40. with Sem_Util; use Sem_Util;
  41. with Sinfo;    use Sinfo;
  42. with Snames;   use Snames;
  43. with Tbuild;   use Tbuild;
  44. with Uintp;    use Uintp;
  45.  
  46. package body Exp_Disp is
  47.  
  48.    Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
  49.       (Set_Prim_Op_Address     => RE_Set_Prim_Op_Address,
  50.        Get_Prim_Op_Address     => RE_Get_Prim_Op_Address,
  51.        Set_Inheritance_Depth   => RE_Set_Inheritance_Depth,
  52.        Get_Inheritance_Depth   => RE_Get_Inheritance_Depth,
  53.        Set_Ancestor_Tags       => RE_Set_Ancestor_Tags,
  54.        Get_Ancestor_Tags       => RE_Get_Ancestor_Tags,
  55.        DT_Size                 => RE_DT_Size,
  56.        Inherit_DT              => RE_Inherit_DT,
  57.        CW_Membership           => RE_CW_Membership);
  58.  
  59.    CPP_Actions : constant array (DT_Access_Action) of RE_Id :=
  60.       (Set_Prim_Op_Address     => RE_Set_Vfunction_Address,
  61.        Get_Prim_Op_Address     => RE_Get_Vfunction_Address,
  62.        Set_Inheritance_Depth   => RE_Set_Idepth,
  63.        Get_Inheritance_Depth   => RE_Get_Idepth,
  64.        Set_Ancestor_Tags       => RE_Set_Ancestor_Vptrs,
  65.        Get_Ancestor_Tags       => RE_Get_Ancestor_Vptrs,
  66.        DT_Size                 => RE_Vtable_Size,
  67.        Inherit_DT              => RE_Inherit_Vtable,
  68.        CW_Membership           => RE_CPP_Membership);
  69.  
  70.    Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
  71.       (Set_Prim_Op_Address     => True,
  72.        Get_Prim_Op_Address     => False,
  73.        Set_Inheritance_Depth   => True,
  74.        Get_Inheritance_Depth   => False,
  75.        Set_Ancestor_Tags       => True,
  76.        Get_Ancestor_Tags       => False,
  77.        DT_Size                 => False,
  78.        Inherit_DT              => True,
  79.        CW_Membership           => False);
  80.  
  81.    Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
  82.      (Set_Prim_Op_Address     => 3,
  83.       Get_Prim_Op_Address     => 2,
  84.       Set_Inheritance_Depth   => 2,
  85.       Get_Inheritance_Depth   => 1,
  86.       Set_Ancestor_Tags       => 2,
  87.       Get_Ancestor_Tags       => 1,
  88.       DT_Size                 => 1,
  89.       Inherit_DT              => 3,
  90.       CW_Membership           => 2);
  91.  
  92.    ---------------------------
  93.    -- Make_DT_Access_Action --
  94.    ---------------------------
  95.  
  96.    function Make_DT_Access_Action
  97.      (Typ    : Entity_Id;
  98.       Action : DT_Access_Action;
  99.       Args   : List_Id)
  100.       return Node_Id
  101.    is
  102.       Loc         : constant Source_Ptr := Sloc (First (Args));
  103.       Action_Name : Entity_Id;
  104.    begin
  105.       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
  106.  
  107.       if Is_CPP_Class (Root_Type (Typ)) then
  108.          Action_Name := RTE (CPP_Actions (Action));
  109.       else
  110.          Action_Name := RTE (Ada_Actions (Action));
  111.       end if;
  112.  
  113.       if Action_Is_Proc (Action) then
  114.          return
  115.            Make_Procedure_Call_Statement (Loc,
  116.              Name => New_Reference_To (Action_Name, Loc),
  117.              Parameter_Associations => Args);
  118.       else
  119.          return
  120.            Make_Function_Call (Loc,
  121.              Name => New_Reference_To (Action_Name, Loc),
  122.              Parameter_Associations => Args);
  123.       end if;
  124.    end Make_DT_Access_Action;
  125.  
  126.    -------------------------
  127.    -- Set_All_DT_Position --
  128.    -------------------------
  129.  
  130.    procedure Set_All_DT_Position (Typ : Entity_Id) is
  131.       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
  132.       Nb_Prim    : Int;
  133.       Prim       : Entity_Id;
  134.       The_Tag    : constant Entity_Id := Tag_Component (Typ);
  135.       Prim_Elmt  : Elmt_Id;
  136.  
  137.    begin
  138.  
  139.       --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
  140.       --  give a coherent set of information
  141.  
  142.       if Is_CPP_Class (Typ) then
  143.  
  144.          --  Compute the number of primitive operations in the main Vtable
  145.  
  146.          Prim_Elmt := First_Prim;
  147.          Nb_Prim := 0;
  148.          while Present (Prim_Elmt) loop
  149.             Prim := Node (Prim_Elmt);
  150.  
  151.             if Present (Alias (Prim)) then
  152.                Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
  153.             end if;
  154.  
  155.             if No (DTC_Entity (Prim)) then
  156.                Error_Msg_NE
  157.                  ("is a primitive operation of&, pragma CPP_Virtual required",
  158.                   Prim, Typ);
  159.  
  160.             elsif DTC_Entity (Prim) = The_Tag then
  161.                Nb_Prim := Nb_Prim + 1;
  162.                if DT_Position (Prim) = No_Uint then
  163.                   Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
  164.                end if;
  165.             end if;
  166.             Prim_Elmt := Next_Elmt (Prim_Elmt);
  167.          end loop;
  168.  
  169.          --  Check that the declared size of the Vtable is bigger or equal
  170.          --  than the number of primitive operations (if bigger it means that
  171.          --  some of the c++ virtual functions were not imported, that is
  172.          --  allowed)
  173.  
  174.          if DT_Entry_Count (The_Tag) = No_Uint then
  175.             Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
  176.  
  177.          elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Nb_Prim then
  178.             Error_Msg_N ("not enough room in the Vtable for all virtual"
  179.               & " functions", The_Tag);
  180.          end if;
  181.  
  182.          --  Check that Positions are not duplicate nor outside the range of
  183.          --  the Vtable
  184.  
  185.          declare
  186.             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
  187.             Pos  : Int;
  188.             Prim_Pos_Table : array (1 .. Size) of Entity_Id
  189.               := (others => Empty);
  190.  
  191.          begin
  192.  
  193.             Prim_Elmt := First_Prim;
  194.             while Present (Prim_Elmt) loop
  195.                Prim := Node (Prim_Elmt);
  196.  
  197.                if DTC_Entity (Prim) = The_Tag then
  198.                   Pos := UI_To_Int (DT_Position (Prim));
  199.  
  200.                   if Pos not in Prim_Pos_Table'Range then
  201.                      Error_Msg_N
  202.                        ("position not in range of virtual table", Prim);
  203.  
  204.                   elsif Present (Prim_Pos_Table (Pos)) then
  205.                      Error_Msg_NE ("cannot be at the same position in the"
  206.                        & " vtable than&", Prim, Prim_Pos_Table (Pos));
  207.  
  208.                   else
  209.                      Prim_Pos_Table (Pos) := Prim;
  210.                   end if;
  211.                end if;
  212.  
  213.                Prim_Elmt := Next_Elmt (Prim_Elmt);
  214.             end loop;
  215.          end;
  216.  
  217.       --  For regular Ada tagged types, just set the DT_Position for each
  218.       --  primitive operation.
  219.  
  220.       else
  221.          Nb_Prim := 0;
  222.          Prim_Elmt := First_Prim;
  223.          while Present (Prim_Elmt) loop
  224.             Nb_Prim := Nb_Prim + 1;
  225.             Prim := Node (Prim_Elmt);
  226.             Set_DTC_Entity (Prim, The_Tag);
  227.             Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
  228.             Prim_Elmt := Next_Elmt (Prim_Elmt);
  229.          end loop;
  230.  
  231.          Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
  232.       end if;
  233.    end Set_All_DT_Position;
  234.  
  235.  
  236.    -------------
  237.    -- Make_DT --
  238.    -------------
  239.  
  240.    function Make_DT (Typ : Entity_Id) return List_Id is
  241.       Result  : constant List_Id := New_List;
  242.       Loc     : constant Source_Ptr := Sloc (Typ);
  243.  
  244.       Tname       : constant Name_Id := Chars (Typ);
  245.       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
  246.       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
  247.       Name_ATT    : constant Name_Id := New_External_Name (Tname, 'B');
  248.  
  249.       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
  250.       DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
  251.       ATT    : constant Node_Id := Make_Defining_Identifier (Loc, Name_ATT);
  252.  
  253.       I_Depth         : Int;
  254.       Generalized_Tag : Entity_Id;
  255.  
  256.    begin
  257.       if Is_CPP_Class (Root_Type (Typ)) then
  258.          Generalized_Tag := RTE (RE_Vtable_Ptr);
  259.       else
  260.          Generalized_Tag := RTE (RE_Tag);
  261.       end if;
  262.  
  263.       --  Create the Dispatch_Table object as an array of storage element
  264.       --   DT : Storage_Array (1 .. DT_Size (nb_prim));
  265.  
  266.       Append_To (Result,
  267.         Make_Object_Declaration (Loc,
  268.           Defining_Identifier => DT,
  269.           Aliased_Present     => True,
  270.           Object_Definition   =>
  271.             Make_Subtype_Indication (Loc,
  272.               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
  273.               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
  274.                 Constraints => New_List (
  275.                   Make_Range (Loc,
  276.                     Low_Bound  => Make_Integer_Literal (Loc, Uint_1),
  277.                     High_Bound =>
  278.                       Make_DT_Access_Action (Typ,
  279.                         Action => DT_Size,
  280.                         Args   => New_List (
  281.                           Make_Integer_Literal (Loc,
  282.                             DT_Entry_Count (Tag_Component (Typ)))))))))));
  283.  
  284.       --  Create the pointer to the dispatch table
  285.       --    DT_Ptr : Tag := Tag!(DT'Address);                 Ada case
  286.       --  or
  287.       --    DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address);   CPP case
  288.  
  289.  
  290.       Append_To (Result,
  291.         Make_Object_Declaration (Loc,
  292.           Defining_Identifier => DT_Ptr,
  293.           Constant_Present    => True,
  294.           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
  295.           Expression          =>
  296.             Make_Unchecked_Type_Conversion (Loc,
  297.               Subtype_Mark => New_Reference_To (Generalized_Tag, Loc),
  298.               Expression   =>
  299.                 Make_Attribute_Reference (Loc,
  300.                   Prefix         => New_Reference_To (DT, Loc),
  301.                   Attribute_Name => Name_Address))));
  302.  
  303.       --  Set Access_Disp_Table field to be the dispatch table pointer
  304.  
  305.       Set_Access_Disp_Table (Typ, DT_Ptr);
  306.  
  307.       --  Count ancestors to compute the inheritance depth. For private
  308.       --  extensions, always go to the full view in order to compute the real
  309.       --  inheritance depth.
  310.  
  311.       declare
  312.          Parent_Type : Entity_Id := Typ;
  313.          P           : Entity_Id;
  314.       begin
  315.          I_Depth := 0;
  316.  
  317.          loop
  318.             P := Etype (Parent_Type);
  319.  
  320.             if Is_Private_Type (P) then
  321.                P := Full_View (Base_Type (P));
  322.             end if;
  323.  
  324.             exit when P = Parent_Type;
  325.  
  326.             I_Depth := I_Depth + 1;
  327.             Parent_Type := P;
  328.          end loop;
  329.       end;
  330.  
  331.       --  Generate Ancestor tags Table:
  332.       --   ATT : aliased Address_Array (0 .. I_Depth);
  333.  
  334.       Append_To (Result,
  335.         Make_Object_Declaration (Loc,
  336.           Defining_Identifier => ATT,
  337.           Aliased_Present     => True,
  338.           Object_Definition   =>
  339.             Make_Subtype_Indication (Loc,
  340.               Subtype_Mark => New_Reference_To (RTE (RE_Address_Array), Loc),
  341.               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
  342.                 Constraints => New_List (
  343.                   Make_Range (Loc,
  344.                     Low_Bound  => Make_Integer_Literal (Loc, Uint_0),
  345.                     High_Bound =>
  346.                       Make_Integer_Literal (Loc,
  347.                         UI_From_Int (Int (I_Depth)))))))));
  348.  
  349.       --  Put the Address of the Ancestor Table in the Dispatch Table
  350.  
  351.       Append_To (Result,
  352.         Make_DT_Access_Action (Typ,
  353.           Action => Set_Ancestor_Tags,
  354.           Args   => New_List (
  355.             New_Reference_To (DT_Ptr, Loc),                  -- DTptr
  356.               Make_Attribute_Reference (Loc,                 -- Value
  357.               Prefix          => New_Reference_To (ATT, Loc),
  358.               Attribute_Name  => Name_Address))));
  359.  
  360.  
  361.       --  For a root type set the Inheritance_Depth and fill the Ancestor Table
  362.       --  Direct Ada descendant of a CPP_Class are considered
  363.  
  364.       if Typ = Etype (Typ)
  365.         or else (Is_CPP_Class (Etype (Typ)) and then not Is_CPP_Class (Typ))
  366.       then
  367.  
  368.          --  Set_Inheritance_Depth (DT_ptr, Idepth)
  369.  
  370.          Append_To (Result,
  371.            Make_DT_Access_Action (Typ,
  372.            Action => Set_Inheritance_Depth,
  373.            Args   => New_List (
  374.              New_Reference_To (DT_Ptr, Loc),                       -- DTptr
  375.              Make_Integer_Literal (Loc, UI_From_Int (I_Depth))))); -- Value
  376.  
  377.  
  378.          --  ATT (0) := Address!(DT_Ptr);
  379.  
  380.          Append_To (Result,
  381.            Make_Assignment_Statement (Loc,
  382.              Name =>
  383.                Make_Indexed_Component (Loc,
  384.                  Prefix      => New_Reference_To (ATT, Loc),
  385.                  Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))),
  386.               Expression =>
  387.                 Make_Unchecked_Type_Conversion (Loc,
  388.                   Subtype_Mark => New_Reference_To (RTE (RE_Address), Loc),
  389.                   Expression   => New_Reference_To (DT_Ptr, Loc))));
  390.  
  391.       --  For a derived type, that is not a direct CPP_Class, call Inherit_DT:
  392.       --     Inherit_DT (Parent_Typ'Tag, DT_Ptr, Parent_Typ'DT_Entry_Count);
  393.  
  394.       elsif not Is_CPP_Class (Typ) then
  395.  
  396.          Append_To (Result,
  397.            Make_DT_Access_Action (Typ,
  398.              Action => Inherit_DT,
  399.              Args   => New_List (
  400.                New_Reference_To                           -- Old_DTptr
  401.                  (Access_Disp_Table (Etype (Typ)), Loc),
  402.  
  403.                New_Reference_To (DT_Ptr, Loc),            -- New_DTptr
  404.  
  405.                Make_Integer_Literal (Loc,                 -- Entry_Count
  406.                  DT_Entry_Count (Tag_Component (Etype (Typ)))))));
  407.       end if;
  408.  
  409.       return Result;
  410.    end Make_DT;
  411.  
  412.    -------------
  413.    -- Fill_DT --
  414.    -------------
  415.  
  416.    function Fill_DT_Entry
  417.      (Loc  : Source_Ptr;
  418.       Prim : Entity_Id)
  419.       return Node_Id
  420.    is
  421.       Typ    : constant Entity_Id := Scope (DTC_Entity (Prim));
  422.       DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ);
  423.  
  424.    begin
  425.       return
  426.         Make_DT_Access_Action (Typ,
  427.           Action => Set_Prim_Op_Address,
  428.           Args   => New_List (
  429.             New_Reference_To (DT_Ptr, Loc),                     -- DTptr
  430.  
  431.             Make_Integer_Literal (Loc, DT_Position (Prim)),     -- Position
  432.  
  433.             Make_Attribute_Reference (Loc,                      -- Value
  434.               Prefix          => New_Reference_To (Prim, Loc),
  435.               Attribute_Name  => Name_Address)));
  436.    end Fill_DT_Entry;
  437.  
  438.    --------------------------
  439.    -- Expand_Dispatch_Call --
  440.    --------------------------
  441.  
  442.    procedure Expand_Dispatch_Call (Call_Node : Node_Id) is
  443.       Call_Typ       : constant Entity_Id := Etype (Call_Node);
  444.       Ctrl_Arg       : constant Node_Id := Controlling_Argument (Call_Node);
  445.       Loc            : constant Source_Ptr := Sloc (Call_Node);
  446.       Param_List     : constant List_Id := Parameter_Associations (Call_Node);
  447.       Subp           : constant Entity_Id  := Entity (Name (Call_Node));
  448.  
  449.       CW_Typ         : Entity_Id;
  450.       Itype_Node     : Node_Id;
  451.       New_Call       : Node_Id;
  452.       New_Call_Name  : Node_Id;
  453.       New_Params     : List_Id := No_List;
  454.       Param          : Node_Id;
  455.       Res_Typ        : Entity_Id;
  456.       Subp_Ptr_Typ   : Entity_Id;
  457.       Subp_Typ       : Entity_Id;
  458.       Typ            : Entity_Id;
  459.  
  460.       function New_Value (From : Node_Id) return Node_Id;
  461.       --  From is the original Expression. New_Value is equivalent to
  462.       --  Duplicate_Subexpr with an explicit dereference when From is an
  463.       --  access parameter
  464.  
  465.       function New_Value (From : Node_Id) return Node_Id is
  466.          Res : constant Node_Id := Duplicate_Subexpr (From);
  467.  
  468.       begin
  469.          if Is_Access_Type (Etype (From)) then
  470.             return Make_Explicit_Dereference (Sloc (From), Res);
  471.          else
  472.             return Res;
  473.          end if;
  474.       end New_Value;
  475.  
  476.    begin
  477.       --  Expand_Dispatch is called directly from the semantics, so we need
  478.       --  a check to see whether expansion is active before proceeding
  479.  
  480.       if not Expander_Active then
  481.          return;
  482.       end if;
  483.  
  484.       --  Definition of the ClassWide Type and the Tagged type
  485.  
  486.       if Is_Access_Type (Etype (Ctrl_Arg)) then
  487.          CW_Typ := Designated_Type (Etype (Ctrl_Arg));
  488.       else
  489.          CW_Typ := Etype (Ctrl_Arg);
  490.       end if;
  491.  
  492.       Typ := Root_Type (CW_Typ);
  493.  
  494.       if Is_CPP_Class (Root_Type (Typ)) then
  495.  
  496.          --  Create a new parameter list with the displaced 'this'
  497.  
  498.          New_Params := New_List;
  499.          Param := First_Actual (Call_Node);
  500.          while Present (Param) loop
  501.  
  502.             --  We assume that dispatching through the main dispatch table
  503.             --  (referenced by Tag_Component) doesn't require a displacement
  504.             --  so the expansion below is only done when dispatching on
  505.             --  another vtable pointer, in which case the first argument
  506.             --  is expanded into :
  507.  
  508.             --     typ!(Displaced_This (Address!(Param)))
  509.  
  510.             if Param = Ctrl_Arg
  511.               and then DTC_Entity (Subp) /= Tag_Component (Typ)
  512.             then
  513.                Append_To (New_Params,
  514.  
  515.                  Make_Unchecked_Type_Conversion (Loc,
  516.                    Subtype_Mark => New_Reference_To (Etype (Param), Loc),
  517.                    Expression   =>
  518.                      Make_Function_Call (Loc,
  519.                        Name => New_Reference_To (RTE (RE_Displaced_This), Loc),
  520.                        Parameter_Associations => New_List (
  521.  
  522.                         --  Current_This
  523.  
  524.                          Make_Unchecked_Type_Conversion (Loc,
  525.                            Subtype_Mark =>
  526.                              New_Reference_To (RTE (RE_Address), Loc),
  527.                            Expression   => Relocate_Node (Param)),
  528.  
  529.                         --  Vptr
  530.  
  531.                          Make_Selected_Component (Loc,
  532.                             Prefix => Duplicate_Subexpr (Ctrl_Arg),
  533.                             Selector_Name =>
  534.                               New_Reference_To (DTC_Entity (Subp), Loc)),
  535.  
  536.                         --  Position
  537.  
  538.                          Make_Integer_Literal (Loc, DT_Position (Subp))))));
  539.  
  540.             else
  541.                Append_To (New_Params, Relocate_Node (Param));
  542.             end if;
  543.  
  544.             Param := Next_Actual (Param);
  545.          end loop;
  546.  
  547.       elsif Present (Param_List) then
  548.  
  549.          --  Generate the Tag checks when appropriate
  550.  
  551.          New_Params := New_List;
  552.  
  553.          Param := First_Actual (Call_Node);
  554.          while Present (Param) loop
  555.  
  556.             --  No tag check with itself
  557.  
  558.             if Param = Ctrl_Arg then
  559.                Append_To (New_Params, Relocate_Node (Param));
  560.  
  561.             --  No tag check for parameter whose type is neither tagged nor
  562.             --  access to tagged (for access parameters)
  563.  
  564.             elsif No (Find_Controlling_Arg (Param)) then
  565.                Append_To (New_Params, Relocate_Node (Param));
  566.  
  567.             --  No tag check for function dispatching on result it the
  568.             --  Tag given by the context is this one
  569.  
  570.             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
  571.                Append_To (New_Params, Relocate_Node (Param));
  572.  
  573.             --  "=" is the only dispatching operation allowed to get
  574.             --  operands with incompatible tags (it just returns false)
  575.  
  576.             elsif Chars (Subp) = Name_Op_Eq then
  577.                Append_To (New_Params, Relocate_Node (Param));
  578.  
  579.             --  No check in presence of suppress flags
  580.  
  581.             elsif Tag_Checks_Suppressed (Etype (Param))
  582.               or else (Is_Access_Type (Etype (Param))
  583.                          and then Tag_Checks_Suppressed
  584.                                     (Designated_Type (Etype (Param))))
  585.             then
  586.                Append_To (New_Params, Relocate_Node (Param));
  587.  
  588.             --  Optimization: no tag checks if the parameters are identical
  589.  
  590.             elsif Is_Entity_Name (Param)
  591.               and then Is_Entity_Name (Ctrl_Arg)
  592.               and then Entity (Param) = Entity (Ctrl_Arg)
  593.             then
  594.                Append_To (New_Params, Relocate_Node (Param));
  595.  
  596.             --  Now we need to generate the Tag check
  597.  
  598.             else
  599.                --  Generate code for tag equality check
  600.                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
  601.  
  602.                Insert_Action (Ctrl_Arg,
  603.                  Make_If_Statement (Loc,
  604.                    Condition =>
  605.                      Make_Op_Ne (Loc,
  606.                        Left_Opnd =>
  607.                          Make_Selected_Component (Loc,
  608.                            Prefix => New_Value (Ctrl_Arg),
  609.                            Selector_Name =>
  610.                              New_Reference_To (Tag_Component (Typ), Loc)),
  611.  
  612.                        Right_Opnd =>
  613.                          Make_Selected_Component (Loc,
  614.                            Prefix =>
  615.                              Make_Unchecked_Type_Conversion (Loc,
  616.                                Subtype_Mark => New_Occurrence_Of (Typ, Loc),
  617.                                Expression   => New_Value (Param)),
  618.                            Selector_Name =>
  619.                              New_Reference_To (Tag_Component (Typ), Loc))),
  620.  
  621.                    Then_Statements =>
  622.                      New_List (New_Constraint_Error (Loc))));
  623.  
  624.                Append_To (New_Params, Relocate_Node (Param));
  625.             end if;
  626.  
  627.             Param := Next_Actual (Param);
  628.          end loop;
  629.       end if;
  630.  
  631.       --  Generate the appropriate Subprogram pointer type
  632.  
  633.       if  Etype (Subp) = Typ then
  634.          Res_Typ := CW_Typ;
  635.       else
  636.          Res_Typ :=  Etype (Subp);
  637.       end if;
  638.  
  639.       Itype_Node := Make_Implicit_Types (Loc);
  640.       Insert_Action (Ctrl_Arg, Itype_Node);
  641.       Subp_Typ  := New_Itype (E_Subprogram_Type, Itype_Node);
  642.       Subp_Ptr_Typ := New_Itype (E_Access_Subprogram_Type, Itype_Node);
  643.       Set_Etype (Subp_Typ, Res_Typ);
  644.  
  645.       --  Create a new list of parameters which is a copy of the old formal
  646.       --  list including the creation of a new set of matching entities.
  647.  
  648.       declare
  649.          Old_Formal : Entity_Id := First_Formal (Subp);
  650.          New_Formal : Entity_Id;
  651.       begin
  652.          if Present (Old_Formal) then
  653.             New_Formal := New_Copy (Old_Formal);
  654.             Set_First_Entity (Subp_Typ, New_Formal);
  655.             Param := First_Actual (Call_Node);
  656.             loop
  657.  
  658.                --  Change all the controlling argument types to be class-wide
  659.                --  to avoid a recursion in dispatching
  660.  
  661.                if Is_Controlling_Actual (Param) then
  662.                   Set_Etype (New_Formal, Etype (Param));
  663.                end if;
  664.  
  665.                Old_Formal := Next_Formal (Old_Formal);
  666.                exit when No (Old_Formal);
  667.  
  668.                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
  669.                New_Formal := Next_Entity (New_Formal);
  670.                Param := Next_Actual (Param);
  671.             end loop;
  672.          end if;
  673.       end;
  674.  
  675.       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
  676.       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
  677.  
  678.       --  Generate:
  679.       --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
  680.  
  681.       New_Call_Name :=
  682.         Make_Unchecked_Type_Conversion (Loc,
  683.           Subtype_Mark => New_Reference_To (Subp_Ptr_Typ, Loc),
  684.           Expression   =>
  685.             Make_DT_Access_Action (Typ,
  686.               Action => Get_Prim_Op_Address,
  687.               Args => New_List (
  688.  
  689.                --  Vptr
  690.  
  691.                 Make_Selected_Component (Loc,
  692.                   Prefix => Duplicate_Subexpr (Ctrl_Arg),
  693.                   Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)),
  694.  
  695.                --  Position
  696.  
  697.                 Make_Integer_Literal (Loc, DT_Position (Subp)))));
  698.  
  699.  
  700.       if Nkind (Call_Node) = N_Function_Call then
  701.          New_Call :=
  702.            Make_Function_Call (Loc,
  703.              Name => New_Call_Name,
  704.              Parameter_Associations => New_Params);
  705.  
  706.       else
  707.          New_Call :=
  708.            Make_Procedure_Call_Statement (Loc,
  709.              Name => New_Call_Name,
  710.              Parameter_Associations => New_Params);
  711.       end if;
  712.  
  713.       Rewrite_Substitute_Tree (Call_Node, New_Call);
  714.       Analyze (Call_Node);
  715.       Resolve (Call_Node, Call_Typ);
  716.    end Expand_Dispatch_Call;
  717.  
  718.    -----------------------------
  719.    -- Set_Default_Constructor --
  720.    -----------------------------
  721.  
  722.    procedure Set_Default_Constructor (Typ : Entity_Id) is
  723.       Loc   : Source_Ptr;
  724.       Init  : Entity_Id;
  725.       Param : Entity_Id;
  726.       Decl  : Node_Id;
  727.       E     : Entity_Id;
  728.    begin
  729.  
  730.       --  Look for the default constructor entity
  731.       --  For now only the default constructor has the flag Is_Constructor.
  732.  
  733.       E := Next_Entity (Typ);
  734.       while Present (E)
  735.         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
  736.       loop
  737.          E := Next_Entity (E);
  738.       end loop;
  739.  
  740.       --  Create the init procedure
  741.  
  742.       if Present (E) then
  743.          Loc   := Sloc (E);
  744.          Init  := Make_Defining_Identifier (Loc, Name_uInit_Proc);
  745.          Param := Make_Defining_Identifier (Loc, Name_X);
  746.          Decl  :=
  747.            Make_Subprogram_Declaration (Loc,
  748.              Make_Procedure_Specification (Loc,
  749.                Defining_Unit_Name => Init,
  750.                Parameter_Specifications => New_List (
  751.                  Make_Parameter_Specification (Loc,
  752.                    Defining_Identifier => Param,
  753.                    Parameter_Type      =>
  754.                      Make_Access_Definition (Loc,
  755.                       Subtype_Mark => New_Reference_To (Typ, Loc))))));
  756.  
  757.          Set_Init_Proc (Typ, Init);
  758.          Set_Is_Imported (Init);
  759.          Set_Interface_Name (Init, Interface_Name (E));
  760.          Set_Convention (Init, Convention_C);
  761.          Set_Is_Public (Init);
  762.          Set_Has_Completion (Init);
  763.       end if;
  764.    end Set_Default_Constructor;
  765.  
  766. end Exp_Disp;
  767.