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 / sem_disp.adb < prev    next >
Text File  |  1996-09-28  |  16KB  |  525 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             S E M _ D I S P                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.62 $                             --
  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 Debug;    use Debug;
  27. with Elists;   use Elists;
  28. with Einfo;    use Einfo;
  29. with Exp_Disp; use Exp_Disp;
  30. with Errout;   use Errout;
  31. with Nlists;   use Nlists;
  32. with Output;   use Output;
  33. with Sem_Ch6;  use Sem_Ch6;
  34. with Sem_Util; use Sem_Util;
  35. with Snames;   use Snames;
  36. with Sinfo;    use Sinfo;
  37. with Uintp;    use Uintp;
  38.  
  39. package body Sem_Disp is
  40.  
  41.    -----------------------
  42.    -- Local Subprograms --
  43.    -----------------------
  44.  
  45.    procedure Override_Dispatching_Operation
  46.      (Tagged_Type : Entity_Id;
  47.       Prev_Op     : Entity_Id;
  48.       New_Op      : Entity_Id);
  49.    --  Replace an implicit dispatching operation with an  explicit one.
  50.    --  Prev_Op is an inherited primitive operation which is overriden by
  51.    --  the explicit declaration of New_Op.
  52.  
  53.    procedure Add_Dispatching_Operation
  54.      (Tagged_Type : Entity_Id;
  55.       New_Op      : Entity_Id);
  56.    --  Add New_Op in the list of primitive operations of Tagged_Type
  57.  
  58.    function Check_Controlling_Type
  59.      (T    : Entity_Id;
  60.       Subp : Entity_Id)
  61.       return Entity_Id;
  62.       --  T is the type of a formal parameter of subp. Returns the tagged
  63.       --  if the parameter can be a controlling argument, empty otherwise
  64.  
  65.    procedure Check_Controlling_Formals
  66.      (Typ  : Entity_Id;
  67.       Subp : Entity_Id);
  68.    --  Checks that all controling parameters of Subp are of type Typ.
  69.  
  70.    ----------------------------
  71.    -- Check_Controlling_Type --
  72.    ----------------------------
  73.  
  74.    function Check_Controlling_Type
  75.      (T    : Entity_Id;
  76.       Subp : Entity_Id)
  77.       return Entity_Id
  78.    is
  79.       Tagged_Type : Entity_Id := Empty;
  80.  
  81.    begin
  82.       if Is_Tagged_Type (T) then
  83.          Tagged_Type := Base_Type (T);
  84.  
  85.       elsif Ekind (T) = E_Anonymous_Access_Type
  86.         and then Is_Tagged_Type (Designated_Type (T))
  87.         and then Ekind (Designated_Type (T)) /= E_Incomplete_Type
  88.       then
  89.          Tagged_Type := Base_Type (Designated_Type (T));
  90.       end if;
  91.  
  92.       if No (Tagged_Type)
  93.         or else Is_Class_Wide_Type (Tagged_Type)
  94.       then
  95.          return Empty;
  96.  
  97.       --  The dispatching type and the primitive operation must be defined
  98.       --  in the same scope except for internal operations.
  99.  
  100.       elsif Scope (Subp) = Scope (Tagged_Type)
  101.         or else Is_Internal (Subp)
  102.       then
  103.          return Tagged_Type;
  104.       else
  105.          return Empty;
  106.       end if;
  107.    end Check_Controlling_Type;
  108.  
  109.    ---------------------------
  110.    -- Find_Dispatching_Type --
  111.    ---------------------------
  112.  
  113.    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
  114.       Formal    : Entity_Id;
  115.       Ctrl_Type : Entity_Id;
  116.  
  117.    begin
  118.       if Present (DTC_Entity (Subp)) then
  119.          return Scope (DTC_Entity (Subp));
  120.  
  121.       else
  122.          Formal := First_Formal (Subp);
  123.          while Present (Formal) loop
  124.             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
  125.             if Present (Ctrl_Type) then
  126.                return Ctrl_Type;
  127.             end if;
  128.             Formal := Next_Formal (Formal);
  129.          end loop;
  130.  
  131.       --  The subprogram may also be dispatching on result
  132.  
  133.          if Present (Etype (Subp)) then
  134.             Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
  135.             if Present (Ctrl_Type) then
  136.                return Ctrl_Type;
  137.             end if;
  138.          end if;
  139.       end if;
  140.  
  141.       return Empty;
  142.    end Find_Dispatching_Type;
  143.  
  144.    -------------------------------
  145.    -- Check_Controlling_Formals --
  146.    -------------------------------
  147.  
  148.    procedure Check_Controlling_Formals
  149.      (Typ  : Entity_Id;
  150.       Subp : Entity_Id)
  151.    is
  152.       Formal    : Entity_Id;
  153.       Ctrl_Type : Entity_Id;
  154.  
  155.    begin
  156.       Formal := First_Formal (Subp);
  157.       while Present (Formal) loop
  158.          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
  159.          if Present (Ctrl_Type) then
  160.             if Ctrl_Type = Typ then
  161.                Set_Is_Controlling_Formal (Formal);
  162.             else
  163.                Error_Msg_N
  164.                  ("operation can be dispatching in only one type", Subp);
  165.             end if;
  166.          end if;
  167.  
  168.          Formal := Next_Formal (Formal);
  169.       end loop;
  170.  
  171.       if Present (Etype (Subp)) then
  172.          Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
  173.  
  174.          if Present (Ctrl_Type) then
  175.             if Ctrl_Type = Typ then
  176.                Set_Has_Controlling_Result (Subp);
  177.             else
  178.                Error_Msg_N
  179.                  ("operation can be dispatching in only one type", Subp);
  180.             end if;
  181.          end if;
  182.       end if;
  183.    end Check_Controlling_Formals;
  184.  
  185.    ---------------------------------
  186.    -- Check_Dispatching_Operation --
  187.    ---------------------------------
  188.  
  189.    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
  190.       Tagged_Seen : Entity_Id;
  191.  
  192.    begin
  193.       if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
  194.          return;
  195.       end if;
  196.  
  197.       Set_Is_Dispatching_Operation (Subp, False);
  198.       Tagged_Seen := Find_Dispatching_Type (Subp);
  199.  
  200.       if No (Tagged_Seen) then
  201.          return;
  202.  
  203.       --  The subprograms build internally after the freezing point (such as
  204.       --  the Init procedure) are not primitives
  205.  
  206.       elsif Is_Frozen (Tagged_Seen)
  207.         and then not Comes_From_Source (Subp)
  208.       then
  209.          return;
  210.  
  211.       --  If the subprogram is not defined in a package spec, the only case
  212.       --  where it can be a dispatching op. if when it overriddes an
  213.       --  operation before the freezing point of the type
  214.  
  215.       elsif (Ekind (Scope (Subp)) /= E_Package
  216.               and then Ekind (Scope (Subp)) /= E_Generic_Package)
  217.         or else In_Package_Body (Scope (Subp))
  218.       then
  219.          if not Comes_From_Source (Subp)
  220.            or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Seen))
  221.          then
  222.             null;
  223.  
  224.          --  If the type is already frozen, the overriding is not allowed
  225.  
  226.          elsif Present (Old_Subp) then
  227.             Error_Msg_N ("overriding of& is too late!", Subp);
  228.             Error_Msg_N
  229.             ("subprogram spec should appear immediately after the type!",
  230.              Subp);
  231.  
  232.          --  If the type is not frozen yet and we are not in the overridding
  233.          --  case it looks suspiciously like an attempt to define a primitive
  234.          --  operation.
  235.  
  236.          elsif not Is_Frozen (Tagged_Seen) then
  237.             Error_Msg_N
  238.               ("?not dispatching (must be defined in a package spec)", Subp);
  239.             return;
  240.  
  241.          --  When the type is frozen, it is legitimate to define a new
  242.          --  non-primitive operation.
  243.  
  244.          else
  245.             return;
  246.          end if;
  247.  
  248.       --  Now, we are sure that the scope is a package spec. If the subprogram
  249.       --  is declared after the freezing point ot the type that's an error
  250.  
  251.       elsif Is_Frozen (Tagged_Seen) then
  252.          Error_Msg_N ("this primitive operation is declared too late", Subp);
  253.          Error_Msg_NE
  254.            ("?no primitive operations for& after this line",
  255.             Freeze_Node (Tagged_Seen),
  256.             Tagged_Seen);
  257.          return;
  258.       end if;
  259.  
  260.       Check_Controlling_Formals (Tagged_Seen, Subp);
  261.  
  262.       --  Now it should be a correct primitive operation, put it in the list
  263.  
  264.       if Present (Old_Subp) then
  265.          Check_Subtype_Conformant (Subp, Old_Subp);
  266.          Override_Dispatching_Operation (Tagged_Seen, Old_Subp, Subp);
  267.  
  268.       else
  269.          Add_Dispatching_Operation (Tagged_Seen, Subp);
  270.       end if;
  271.  
  272.       Set_Is_Dispatching_Operation (Subp, True);
  273.       Set_DT_Position (Subp, No_Uint);
  274.  
  275.    end Check_Dispatching_Operation;
  276.  
  277.    --------------------------------
  278.    --  Add_Dispatching_Operation --
  279.    --------------------------------
  280.  
  281.    procedure Add_Dispatching_Operation
  282.      (Tagged_Type : Entity_Id;
  283.       New_Op      : Entity_Id)
  284.    is
  285.       List : constant Elist_Id := Primitive_Operations (Tagged_Type);
  286.  
  287.    begin
  288.          Append_Elmt (New_Op, List);
  289.    end Add_Dispatching_Operation;
  290.  
  291.    ---------------------------------------
  292.    -- Check_Operation_From_Private_View --
  293.    ---------------------------------------
  294.  
  295.    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
  296.       Tagged_Type : Entity_Id;
  297.    begin
  298.  
  299.       if Is_Dispatching_Operation (Alias (Subp)) then
  300.          Set_Scope (Subp, Current_Scope);
  301.          Tagged_Type := Find_Dispatching_Type (Subp);
  302.          Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
  303.          if Present (Alias (Old_Subp)) then
  304.             Set_Alias (Old_Subp, Alias (Subp));
  305.          end if;
  306.       end if;
  307.    end Check_Operation_From_Private_View;
  308.  
  309.    ----------------------------
  310.    -- Check_Dispatching_Call --
  311.    ----------------------------
  312.  
  313.    procedure Check_Dispatching_Call (N : Node_Id) is
  314.       Actual  : Node_Id;
  315.       Control : Node_Id := Empty;
  316.  
  317.    begin
  318.       --  Find a controlling argument, if any
  319.  
  320.       if Present (Parameter_Associations (N)) then
  321.          Actual := First_Actual (N);
  322.  
  323.          while Present (Actual) loop
  324.             Control := Find_Controlling_Arg (Actual);
  325.             exit when Present (Control);
  326.             Actual := Next_Actual (Actual);
  327.          end loop;
  328.  
  329.          if Present (Control) then
  330.  
  331.             --  Verify that no controlling arguments are statically tagged
  332.  
  333.             if Debug_Flag_E then
  334.                Write_Str ("Found Dispatching call");
  335.                Write_Int (Int (N));
  336.                Write_Eol;
  337.             end if;
  338.  
  339.             Actual := First_Actual (N);
  340.  
  341.             while Present (Actual) loop
  342.                if Actual /= Control then
  343.  
  344.                   if not Is_Controlling_Actual (Actual) then
  345.                      null; -- can be anything
  346.  
  347.                   elsif (Is_Dynamically_Tagged (Actual)) then
  348.                      null; --  valid parameter
  349.  
  350.                   elsif Is_Tag_Indeterminate (Actual) then
  351.  
  352.                      --  The tag is inherited from the enclosing call (the
  353.                      --  node we are currently analyzing). Explicitly expand
  354.                      --  the actual, since the previous call to Expand
  355.                      --  (from Resolve_Call) had no way of knowing about
  356.                      --  the required dispatching.
  357.  
  358.                      Propagate_Tag (Control, Actual);
  359.  
  360.                   else
  361.                      Error_Msg_N
  362.                        ("controlling argument is not dynamically tagged",
  363.                         Actual);
  364.                      return;
  365.                   end if;
  366.                end if;
  367.  
  368.                Actual := Next_Actual (Actual);
  369.             end loop;
  370.  
  371.             --  Mark call as a dispatching call
  372.  
  373.             Set_Controlling_Argument (N, Control);
  374.          end if;
  375.  
  376.       else
  377.          --  If dispatching on result, the enclosing call, if any, will
  378.          --  determine the controlling argument. Otherwise this is the
  379.          --  primitive operation of the root type.
  380.  
  381.          null;
  382.       end if;
  383.    end Check_Dispatching_Call;
  384.  
  385.    ---------------------------
  386.    -- Is_Dynamically_Tagged --
  387.    ---------------------------
  388.  
  389.    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
  390.    begin
  391.       return Find_Controlling_Arg (N) /= Empty;
  392.    end Is_Dynamically_Tagged;
  393.  
  394.    --------------------------
  395.    -- Find_Controlling_Arg --
  396.    --------------------------
  397.  
  398.    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
  399.       Orig_Node : constant Node_Id := Original_Node (N);
  400.       Typ       : Entity_Id;
  401.  
  402.    begin
  403.       --  Dispatching on result case
  404.  
  405.       if Nkind (Orig_Node) = N_Function_Call
  406.         and then Present (Controlling_Argument (Orig_Node))
  407.         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
  408.       then
  409.          return Controlling_Argument (Orig_Node);
  410.  
  411.       --  Normal case
  412.  
  413.       elsif Is_Controlling_Actual (N) then
  414.  
  415.          Typ := Etype (N);
  416.          if Is_Access_Type (Typ) then
  417.             Typ := Designated_Type (Typ);
  418.          end if;
  419.  
  420.          if Is_Class_Wide_Type (Typ) then
  421.             return N;
  422.          end if;
  423.       end if;
  424.  
  425.       return Empty;
  426.    end Find_Controlling_Arg;
  427.  
  428.    --------------------------
  429.    -- Is_Tag_Indeterminate --
  430.    --------------------------
  431.  
  432.    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
  433.       Nam       : Entity_Id;
  434.       Actual    : Node_Id;
  435.       Orig_Node : constant Node_Id := Original_Node (N);
  436.  
  437.    begin
  438.       if Nkind (Orig_Node) = N_Function_Call then
  439.          Nam := Entity (Name (Orig_Node));
  440.  
  441.          if not Has_Controlling_Result (Nam) then
  442.             return False;
  443.  
  444.          --  If there are no actuals, the call is tag-indeterminate
  445.  
  446.          elsif No (Parameter_Associations (Orig_Node)) then
  447.             return True;
  448.  
  449.          else
  450.             Actual := First_Actual (Orig_Node);
  451.  
  452.             while Present (Actual) loop
  453.                if Is_Controlling_Actual (Actual)
  454.                  and then not Is_Tag_Indeterminate (Actual)
  455.                then
  456.                   return False; -- one operand is dispatching
  457.                end if;
  458.  
  459.                Actual := Next_Actual (Actual);
  460.             end loop;
  461.  
  462.             return True;
  463.  
  464.          end if;
  465.  
  466.       elsif Nkind (Orig_Node) = N_Qualified_Expression then
  467.          return Is_Tag_Indeterminate (Expression (Orig_Node));
  468.  
  469.       else
  470.          return False;
  471.       end if;
  472.    end Is_Tag_Indeterminate;
  473.  
  474.    ------------------------------------
  475.    -- Override_Dispatching_Operation --
  476.    ------------------------------------
  477.  
  478.    procedure Override_Dispatching_Operation
  479.      (Tagged_Type : Entity_Id;
  480.       Prev_Op     : Entity_Id;
  481.       New_Op      : Entity_Id)
  482.    is
  483.       Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
  484.  
  485.    begin
  486.       while Node (Op_Elmt) /= Prev_Op loop
  487.          Op_Elmt := Next_Elmt (Op_Elmt);
  488.       end loop;
  489.       Replace_Elmt (Op_Elmt, New_Op);
  490.    end Override_Dispatching_Operation;
  491.  
  492.    -------------------
  493.    -- Propagate_Tag --
  494.    -------------------
  495.  
  496.    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
  497.       Call_Node : Node_Id;
  498.       Arg       : Node_Id;
  499.  
  500.    begin
  501.       if Nkind (Actual) = N_Function_Call then
  502.          Call_Node := Actual;
  503.  
  504.       --  Only other possibility is parenthesized or qualified expression
  505.  
  506.       else
  507.          Call_Node := Expression (Actual);
  508.       end if;
  509.  
  510.       Set_Controlling_Argument (Call_Node, Control);
  511.       Arg := First_Actual (Call_Node);
  512.  
  513.       while Present (Arg) loop
  514.          if Is_Tag_Indeterminate (Arg) then
  515.             Propagate_Tag (Control,  Arg);
  516.          end if;
  517.  
  518.          Arg := Next_Actual (Arg);
  519.       end loop;
  520.  
  521.       Expand_Dispatch_Call (Call_Node);
  522.    end Propagate_Tag;
  523.  
  524. end Sem_Disp;
  525.