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_ch6.adb < prev    next >
Text File  |  1996-09-28  |  25KB  |  698 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              E X P _ C H 6                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.122 $                            --
  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 Exp_Ch7;  use Exp_Ch7;
  29. with Exp_Ch9;  use Exp_Ch9;
  30. with Exp_Disp; use Exp_Disp;
  31. with Exp_Intr; use Exp_Intr;
  32. with Inline;   use Inline;
  33. with Nlists;   use Nlists;
  34. with Nmake;    use Nmake;
  35. with Sem;      use Sem;
  36. with Sem_Ch8;  use Sem_Ch8;
  37. with Sem_Util; use Sem_Util;
  38. with Sinfo;    use Sinfo;
  39. with Snames;   use Snames;
  40. with Stand;    use Stand;
  41. with Tbuild;   use Tbuild;
  42.  
  43. package body Exp_Ch6 is
  44.  
  45.    procedure Expand_Actual_Conversions (N : Node_Id; Subp : Entity_Id);
  46.    --  For each actual of an in-out parameter which is a numeric conversion
  47.    --  of the form T(A), where A denotes a variable, we insert the declaration:
  48.    --
  49.    --     Temp : T := T(A);
  50.    --
  51.    --  prior to the call. Then we replace the actual with a reference to Temp,
  52.    --   and  append the assignment:
  53.    --
  54.    --     A := T' (Temp);
  55.    --
  56.    --  after the call. Here T' is the actual type of variable A.
  57.    --  For out parameters, the initial declaration has no expression.
  58.    --  If A is not an entity name,  we generate instead:
  59.    --
  60.    --  Var  : T' renames A;
  61.    --  Temp : T := Var;       --  omitting expression for out parameter.
  62.    --  ...
  63.    --  Var := T' (Temp);
  64.  
  65.    -------------------------------
  66.    -- Expand_Actual_Conversions --
  67.    -------------------------------
  68.  
  69.    procedure Expand_Actual_Conversions (N : Node_Id; Subp : Entity_Id) is
  70.       Loc       : constant Source_Ptr := Sloc (N);
  71.       Actual    : Node_Id;
  72.       Formal    : Entity_Id;
  73.       Init      : Node_Id;
  74.       N_Node    : Node_Id;
  75.       Post_Call : List_Id := New_List;
  76.       Temp      : Entity_Id;
  77.       Var       : Node_Id;
  78.       V_Typ     : Entity_Id;
  79.  
  80.    begin
  81.       Formal := First_Formal (Subp);
  82.       Actual := First_Actual (N);
  83.  
  84.       while Present (Formal) loop
  85.  
  86.          if Is_Array_Type (Etype (Formal)) and then
  87.              Is_Constrained (Etype (Formal))
  88.          then
  89.             Apply_Length_Check (Actual, Etype (Formal));
  90.          end if;
  91.  
  92.          if Nkind (Actual) = N_Type_Conversion
  93.            and then Is_Numeric_Type (Etype (Formal))
  94.            and then Ekind (Formal) /= E_In_Parameter
  95.          then
  96.             Temp  := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
  97.             V_Typ := Etype (Expression (Actual));
  98.  
  99.             if Is_Entity_Name (Expression (Actual)) then
  100.                Var := Entity (Expression (Actual));
  101.             else
  102.                Var :=
  103.                  Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
  104.  
  105.                N_Node :=
  106.                  Make_Object_Renaming_Declaration (Loc,
  107.                    Defining_Identifier => Var,
  108.                    Subtype_Mark        => New_Occurrence_Of (V_Typ, Loc),
  109.                    Name                => Expression (Actual));
  110.                Insert_Before_And_Analyze (N, N_Node);
  111.             end if;
  112.  
  113.             if Ekind (Formal) = E_In_Out_Parameter then
  114.                Init :=
  115.                  Make_Type_Conversion (Loc,
  116.                    Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc),
  117.                    Expression   => New_Occurrence_Of (Var, Loc));
  118.             else
  119.                Init := Empty;
  120.             end if;
  121.  
  122.             N_Node :=
  123.               Make_Object_Declaration (Loc,
  124.                 Defining_Identifier => Temp,
  125.                 Object_Definition   =>
  126.                   New_Occurrence_Of (Etype (Formal), Loc),
  127.                 Expression => Init);
  128.             Insert_Before_And_Analyze (N, N_Node);
  129.  
  130.             Rewrite_Substitute_Tree
  131.               (Actual, New_Reference_To
  132.                 (Defining_Identifier (N_Node), Loc));
  133.             Analyze (Actual);
  134.  
  135.             Append_To (Post_Call,
  136.               Make_Assignment_Statement (Loc,
  137.                 Name       => New_Occurrence_Of (Var, Loc),
  138.                 Expression => Make_Type_Conversion (Loc,
  139.                   Subtype_Mark => New_Occurrence_Of (V_Typ, Loc),
  140.                   Expression   => New_Occurrence_Of (Temp, Loc))));
  141.          end if;
  142.  
  143.          Formal := Next_Formal (Formal);
  144.          Actual := Next_Actual (Actual);
  145.       end loop;
  146.  
  147.       --  Note: the following code is wrong! N may be the action of a
  148.       --  triggering statement, and hence not be a list member at all???
  149.  
  150.       if not Is_Empty_List (Post_Call) then
  151.          Insert_List_After (N, Post_Call);
  152.       end if;
  153.  
  154.       --  The call node itself is re-analyzed in Expand_Call.
  155.  
  156.    end Expand_Actual_Conversions;
  157.  
  158.    -----------------
  159.    -- Expand_Call --
  160.    -----------------
  161.  
  162.    --  This procedure handles expansion of function calls and procedure call
  163.    --  statements (i.e. it serves as the body for Expand_N_Function_Call and
  164.    --  Expand_N_Procedure_Call_Statement. Processing for calls includes:
  165.  
  166.    --    Supply default expressions for missing arguments
  167.    --    Replace "call" to enumeration literal function by literal itself
  168.    --    Rewrite call to predefined operator as operator
  169.    --    Replace actuals to in-out parameters that are  numeric conversions,
  170.    --    with explicit assignment to temporaries before and after the call.
  171.  
  172.    procedure Expand_Call (N : Node_Id) is
  173.       Loc           : constant Source_Ptr := Sloc (N);
  174.       Subp          : Entity_Id;
  175.       Parent_Subp   : Entity_Id;
  176.       Parent_Formal : Entity_Id;
  177.       Actual        : Node_Id;
  178.       Formal        : Entity_Id;
  179.       Prev          : Node_Id := Empty;
  180.       Scop          : Entity_Id;
  181.  
  182.       procedure Insert_Default;
  183.       --  Internal procedure to insert argument corresponding to Formal.
  184.       --  The value is inserted immediately after Prev, or if Prev is Empty,
  185.       --  (case of empty argument list), then into a new list. In both cases
  186.       --  Prev is set to the inserted default for the next call.
  187.  
  188.       procedure Insert_Default is
  189.          Default : Node_Id;
  190.          Insert  : Node_Id;
  191.          F_Name  : Node_Id;
  192.  
  193.       begin
  194.          Insert := New_Node (N_Parameter_Association, Loc);
  195.          F_Name := New_Node (N_Identifier, Loc);
  196.  
  197.          --  Copy the complete expression tree for each default parameter.
  198.          --  This will ensure that a new Itype is generated (if applicable)
  199.          --  for each such insertion of the expression in the subprogram call.
  200.  
  201.          Default := New_Copy_Tree (Default_Value (Formal));
  202.          Set_Chars (F_Name, Chars (Formal));
  203.          Set_Explicit_Actual_Parameter (Insert, Default);
  204.          Set_Selector_Name (Insert, F_Name);
  205.  
  206.          --  Case of insertion is first named actual
  207.  
  208.          if No (Prev) or else
  209.             Nkind (Parent (Prev)) /= N_Parameter_Association
  210.          then
  211.             Set_Next_Named_Actual (Insert, First_Named_Actual (N));
  212.             Set_First_Named_Actual (N, Default);
  213.  
  214.             if No (Prev) then
  215.                if not Present (Parameter_Associations (N)) then
  216.                   Set_Parameter_Associations (N, New_List);
  217.                   Append (Insert, Parameter_Associations (N));
  218.                end if;
  219.             else
  220.                Insert_After (Prev, Insert);
  221.             end if;
  222.  
  223.          --  Case of insertion is not first named actual
  224.  
  225.          else
  226.             Set_Next_Named_Actual (Insert, Next_Named_Actual (Parent (Prev)));
  227.             Set_Next_Named_Actual (Parent (Prev), Default);
  228.             Append (Insert, Parameter_Associations (N));
  229.          end if;
  230.  
  231.          Prev := Default;
  232.       end Insert_Default;
  233.  
  234.    --  Start of processing for Expand_Call
  235.  
  236.    begin
  237.       --  Case of access to subprogram, where the Name is an explicit
  238.       --  dereference. The type of the name node is a subprogram type,
  239.       --  from which we can retrieve the required signature.
  240.  
  241.       if Nkind (Name (N)) = N_Explicit_Dereference then
  242.          Subp := Etype (Name (N));
  243.          Parent_Subp := Empty;
  244.  
  245.       --  Case of call to simple entry, where the Name is a selected component
  246.       --  whose prefix is the task, and whose selector name is the entry name
  247.  
  248.       elsif Nkind (Name (N)) = N_Selected_Component then
  249.          Subp := Entity (Selector_Name (Name (N)));
  250.          Parent_Subp := Empty;
  251.  
  252.       --  Case of call to member of entry family, where Name is an indexed
  253.       --  component, with the prefix being a selected component giving the
  254.       --  task and entry family name, and the index being the entry index.
  255.  
  256.       elsif Nkind (Name (N)) = N_Indexed_Component then
  257.          Subp := Entity (Selector_Name (Prefix (Name (N))));
  258.          Parent_Subp := Empty;
  259.  
  260.       --  Normal case
  261.  
  262.       else
  263.          Subp := Entity (Name (N));
  264.          Parent_Subp := Alias (Subp);
  265.  
  266.          if Ekind (Subp) = E_Entry then
  267.             Parent_Subp := Empty;
  268.          end if;
  269.       end if;
  270.  
  271.       --  First step, insert default parameter values
  272.  
  273.       Formal := First_Formal (Subp);
  274.       Actual := First_Actual (N);
  275.  
  276.       while Present (Formal) loop
  277.          if Present (Actual) then
  278.  
  279.             --  Check for named and positional parameters in proper place
  280.  
  281.             if Nkind (Parent (Actual)) /= N_Parameter_Association
  282.               or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
  283.             then
  284.                Prev   := Actual;
  285.                Actual := Next_Actual (Actual);
  286.             else
  287.                Insert_Default;
  288.             end if;
  289.  
  290.          --  Trailing actuals are all defaults
  291.  
  292.          else
  293.             Insert_Default;
  294.          end if;
  295.  
  296.          Formal := Next_Formal (Formal);
  297.       end loop;
  298.  
  299.       if Nkind (N) /= N_Entry_Call_Statement
  300.         and then No (Controlling_Argument (N))
  301.         and then Present (Parent_Subp)
  302.       then
  303.          while Present (Alias (Parent_Subp)) loop
  304.             Parent_Subp := Alias (Parent_Subp);
  305.          end loop;
  306.  
  307.          Set_Entity (Name (N), Parent_Subp);
  308.          Subp := Parent_Subp;
  309.  
  310.          --  Expand an explicit conversion for parameter of the inherited type
  311.  
  312.          Formal := First_Formal (Subp);
  313.          Parent_Formal := First_Formal (Parent_Subp);
  314.          Actual := First_Actual (N);
  315.          while Present (Formal) loop
  316.             if (Etype (Formal) /= Etype (Parent_Formal))
  317.               and then not Is_Intrinsic_Subprogram (Subp)
  318.             then
  319.                Rewrite_Substitute_Tree (Actual,
  320.                  Make_Type_Conversion (Sloc (Actual),
  321.                    Subtype_Mark =>
  322.                      New_Occurrence_Of (Etype (Parent_Formal), Sloc (Actual)),
  323.                    Expression   => Relocate_Node (Actual)));
  324.                Set_Etype (Actual, Etype (Parent_Formal));
  325.             end if;
  326.  
  327.             Formal := Next_Formal (Formal);
  328.             Parent_Formal := Next_Formal (Parent_Formal);
  329.             Actual := Next_Actual (Actual);
  330.          end loop;
  331.  
  332.       end if;
  333.  
  334.       --  Some more special cases for cases other than explicit dereference
  335.  
  336.       if Nkind (Name (N)) /= N_Explicit_Dereference then
  337.  
  338.          --  Calls to an enumeration literal are replaced by the literal
  339.          --  The only way that this case occurs is when we have a call to
  340.          --  a function that is a renaming of an enumeration literal. The
  341.          --  normal case of a direct reference to an enumeration literal
  342.          --  has already been dealt with by Resolve_Call
  343.  
  344.          if Ekind (Subp) = E_Enumeration_Literal then
  345.             Rewrite_Substitute_Tree (N, Name (N));
  346.          end if;
  347.       end if;
  348.  
  349.       --  Deals with Dispatch_Call if we still have a call
  350.  
  351.       if (Nkind (N) = N_Function_Call
  352.            or else Nkind (N) =  N_Procedure_Call_Statement)
  353.         and then Present (Controlling_Argument (N))
  354.       then
  355.          Expand_Dispatch_Call (N);
  356.          return;
  357.       end if;
  358.  
  359.       --  Create a transient scope if the resulting type requires it
  360.  
  361.       if Is_Type (Etype (Subp))
  362.         and then Requires_Transient_Scope (Etype (Subp))
  363.       then
  364.          Establish_Transient_Scope (N);
  365.  
  366.          if Controlled_Type (Etype (Subp))
  367.            and then not Is_Return_By_Reference_Type (Etype (Subp))
  368.          then
  369.             Expand_Ctrl_Function_Call (N);
  370.             return;
  371.          end if;
  372.       end if;
  373.  
  374.       if Ekind (Subp) = E_Procedure
  375.          or else Ekind (Subp) = E_Entry
  376.          or else Ekind (Subp) = E_Entry_Family
  377.       then
  378.          Expand_Actual_Conversions (N, Subp);
  379.       end if;
  380.  
  381.       --  If this is a call to an intrinsic subprogram, then perform the
  382.       --  appropriate expansion to the corresponding tree node.
  383.  
  384.       if Is_Intrinsic_Subprogram (Subp) then
  385.          Expand_Intrinsic_Call (N, Subp);
  386.          return;
  387.       end if;
  388.  
  389.       if Ekind (Subp) = E_Function
  390.         or else Ekind (Subp) = E_Procedure
  391.       then
  392.  
  393.          if Is_Inlined (Subp) then
  394.             Add_Inlined_Body (N, Subp);
  395.          end if;
  396.       end if;
  397.  
  398.       --  Check for a protected subprogram.  This is either an intra-object
  399.       --  call, or a protected function call. Protected procedure calls are
  400.       --  rewritten as entry calls and handled accordingly.
  401.  
  402.       Scop := Scope (Subp);
  403.  
  404.       if Nkind (N) /= N_Entry_Call_Statement
  405.         and then Is_Protected_Type (Scop)
  406.       then
  407.  
  408.          --  If the call is an internal one,  it is rewritten as a call to
  409.          --  to the corresponding unprotected subprogram.
  410.  
  411.          declare
  412.             Param : Entity_Id;
  413.             Corr  : Entity_Id;
  414.             Proc  : Entity_Id;
  415.             Rec   : Node_Id;
  416.  
  417.          begin
  418.  
  419.             --  If the protected object is not an enclosing scope, this is
  420.             --  an inter-object call.
  421.             --  ??? This appears to be dead code; inter-object calls
  422.             --      are actually expanded by Exp_Ch9.Build_Simple_Entry_Call.
  423.  
  424.             if not In_Open_Scopes (Scop) then
  425.  
  426.                if Nkind (Name (N)) = N_Selected_Component then
  427.                   Rec := Prefix (Name (N));
  428.  
  429.                elsif Nkind (Name (N)) = N_Indexed_Component then
  430.                   Rec := Prefix (Prefix (Name (N)));
  431.  
  432.                else
  433.                   null;
  434.                   pragma Assert (False);
  435.                end if;
  436.  
  437.                Rewrite_Substitute_Tree (N,
  438.                  Build_Protected_Subprogram_Call (N,
  439.                    Name => New_Occurrence_Of (Subp, Sloc (N)),
  440.                    Rec =>  Convert_Concurrent (Rec, Etype (Rec)),
  441.                    External => True));
  442.  
  443.             else
  444.                Rec := Make_Identifier (Loc, Name_uObject);
  445.                Set_Etype (Rec, Corresponding_Record_Type (Scop));
  446.  
  447.                --  Find enclosing protected operation, and retrieve its first
  448.                --  parameter, which denotes the enclosing protected object.
  449.                --  If the enclosing operation is an entry, we are immediately
  450.                --  within the protected body, and we can retrieve the object
  451.                --  from the service entries procedure.
  452.  
  453.                Proc := Current_Scope;
  454.                while Present (Proc)
  455.                  and then Scope (Proc) /= Scop
  456.                loop
  457.                   Proc := Scope (Proc);
  458.                end loop;
  459.  
  460.                Corr := Protected_Body_Subprogram (Proc);
  461.  
  462.                if No (Corr) then
  463.  
  464.                   --  Previous error left expansion incomplete.
  465.                   --  Nothing to do on this call.
  466.  
  467.                   return;
  468.  
  469.                end if;
  470.  
  471.                Param := Defining_Identifier
  472.                  (First
  473.                    (Parameter_Specifications (Parent (Corr))));
  474.  
  475.                if Is_Subprogram (Proc) then
  476.  
  477.                   Set_Entity (Rec, Param);
  478.                   Set_Analyzed (Rec);
  479.  
  480.                else
  481.                   --  The first parameter of the entry body procedure is a
  482.                   --  pointer to the object. We create a local variable
  483.                   --  of the proper type, duplicating what is done to define
  484.                   --  _object later on.
  485.  
  486.                   declare
  487.                      Decls : List_Id;
  488.                      Obj_Ptr : Entity_Id :=  Make_Defining_Identifier
  489.                                                (Loc, New_Internal_Name ('T'));
  490.                   begin
  491.  
  492.                      Decls := New_List (
  493.                        Make_Full_Type_Declaration (Loc,
  494.                          Defining_Identifier => Obj_Ptr,
  495.                            Type_Definition =>
  496.                               Make_Access_To_Object_Definition (Loc,
  497.                                 Subtype_Indication =>
  498.                                   New_Reference_To
  499.                                (Corresponding_Record_Type (Scop), Loc))));
  500.  
  501.                      Rec := Make_Expression_Actions (Loc,
  502.                         Actions => Decls,
  503.                          Expression => Make_Explicit_Dereference (Loc,
  504.                            Make_Unchecked_Type_Conversion (Loc,
  505.                              Subtype_Mark => New_Reference_To (Obj_Ptr, Loc),
  506.                              Expression => New_Occurrence_Of (Param, Loc))));
  507.                   end;
  508.                end if;
  509.  
  510.                Rewrite_Substitute_Tree (N,
  511.                  Build_Protected_Subprogram_Call (N,
  512.                    Name => Name (N),
  513.                    Rec => Rec,
  514.                    External => False));
  515.  
  516.                if not Is_Subprogram (Proc) then
  517.                   Analyze (Rec);
  518.                end if;
  519.             end if;
  520.          end;
  521.  
  522.          Analyze (N);
  523.       end if;
  524.    end Expand_Call;
  525.  
  526.    ----------------------------
  527.    -- Expand_N_Function_Call --
  528.    ----------------------------
  529.  
  530.    procedure Expand_N_Function_Call (N : Node_Id) is
  531.    begin
  532.       Expand_Call (N);
  533.    end Expand_N_Function_Call;
  534.  
  535.    ---------------------------------------
  536.    -- Expand_N_Procedure_Call_Statement --
  537.    ---------------------------------------
  538.  
  539.    procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
  540.    begin
  541.       Expand_Call (N);
  542.    end Expand_N_Procedure_Call_Statement;
  543.  
  544.    ------------------------------
  545.    -- Expand_N_Subprogram_Body --
  546.    ------------------------------
  547.  
  548.    --  Add return statement if last statement in body is not a return
  549.    --  statement (this makes things easier on Gigi which does not want
  550.    --  to have to handle a missing return).
  551.  
  552.    --  Add call to Activate_Tasks if body is a task activator
  553.  
  554.    procedure Expand_N_Subprogram_Body (N : Node_Id) is
  555.       Loc      : constant Source_Ptr := Sloc (N);
  556.       H        : constant Node_Id    := Handled_Statement_Sequence (N);
  557.       Spec_Id  : Entity_Id;
  558.       Except_H : Node_Id;
  559.       Scop     : Entity_Id;
  560.       Dec      : Node_Id;
  561.       Next_Op : Node_Id;
  562.  
  563.       procedure Add_Termination (S : List_Id);
  564.       --  Append to S a return statement in the procedure case or a Raise
  565.       --  Program_Error in the function case if the last statement is not
  566.       --  already a return or a goto statement.
  567.  
  568.       procedure Add_Termination (S : List_Id) is
  569.          Last_S : constant Node_Id := Last (S);
  570.          Loc_S  : constant Source_Ptr := Sloc (Last_S);
  571.  
  572.       begin
  573.          if Nkind (Last_S) /= N_Return_Statement
  574.            and then Nkind (Last_S) /= N_Goto_Statement
  575.            and then Nkind (Last_S) /= N_Raise_Statement
  576.          then
  577.             if Ekind (Spec_Id) = E_Procedure then
  578.                Append_To (S, Make_Return_Statement (Loc_S));
  579.  
  580.             elsif Ekind (Spec_Id) = E_Function then
  581.                Append_To (S,
  582.                  Make_Raise_Statement (Loc_S,
  583.                    Name => New_Occurrence_Of (Standard_Program_Error, Loc_S)));
  584.             end if;
  585.          end if;
  586.       end Add_Termination;
  587.  
  588.    --  Start of processing for Expand_N_Subprogram_Body
  589.  
  590.    begin
  591.       --  Get entities for subprogram body and spec
  592.  
  593.       if Present (Corresponding_Spec (N)) then
  594.          Spec_Id := Corresponding_Spec (N);
  595.       else
  596.          Spec_Id := Defining_Unit_Simple_Name (Specification (N));
  597.       end if;
  598.  
  599.       --  Returns_By_Ref flag is normally set when the subprogram is frozen
  600.       --  but subprograms with no specs are not frozen
  601.  
  602.       if Acts_As_Spec (N)
  603.         and then Is_Return_By_Reference_Type (Etype (Spec_Id))
  604.       then
  605.          Set_Returns_By_Ref (Spec_Id);
  606.       end if;
  607.  
  608.       --  Now, add a termination for all possible syntactic ends of the
  609.       --  subprogram.  We don't bother to reanalyze the new body with the added
  610.       --  return statement, since it would involve a lot of unnecessary work
  611.       --  that would achieve precisely nothing.
  612.  
  613.       Add_Termination (Statements (H));
  614.  
  615.       if Present (Exception_Handlers (H)) then
  616.          Except_H := First (Exception_Handlers (H));
  617.  
  618.          while Present (Except_H) loop
  619.             Add_Termination (Statements (Except_H));
  620.             Except_H := Next (Except_H);
  621.          end loop;
  622.       end if;
  623.  
  624.       Scop := Scope (Spec_Id);
  625.  
  626.       --  Add discriminal renamings to protected subprograms.
  627.       --  Install new discriminals for expansion of the next
  628.       --  subprogram of this protected type, if any.
  629.  
  630.       if Is_List_Member (N)
  631.         and then Present (Parent (List_Containing (N)))
  632.         and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
  633.       then
  634.          Add_Discriminal_Declarations
  635.            (Declarations (N), Scop, Name_uObject, Loc);
  636.          Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
  637.  
  638.          --  Associate privals and discriminals with the next protected
  639.          --  operation body to be expanded. These are used to expand
  640.          --  references to private data objects and discriminants,
  641.          --  respectively.
  642.  
  643.          Next_Op := Next_Protected_Operation (N);
  644.  
  645.          if Present (Next_Op) then
  646.             Dec := Parent (Base_Type (Scop));
  647.             Set_Privals (Dec, Next_Op, Loc);
  648.             Set_Discriminals (Dec, Next_Op, Loc);
  649.          end if;
  650.  
  651.       end if;
  652.  
  653.    end Expand_N_Subprogram_Body;
  654.  
  655.    -----------------------
  656.    -- Freeze_Subprogram --
  657.    -----------------------
  658.  
  659.    procedure Freeze_Subprogram (N : Node_Id) is
  660.       E : constant Entity_Id := Entity (N);
  661.  
  662.    begin
  663.       --  When a primitive is frozen, enter its name in the corresponding
  664.       --  dispatch table. If the DTC_Entity field is not set this is an
  665.       --  overriden primitive that can be ignored.
  666.  
  667.       if Is_Dispatching_Operation (E)
  668.         and then not Is_Abstract (E)
  669.         and then Present (DTC_Entity (E))
  670.         and then not Is_CPP_Class (Scope (DTC_Entity (E)))
  671.       then
  672.          Insert_After (N, Fill_DT_Entry (Sloc (N), E));
  673.       end if;
  674.  
  675.       --  Mark functions that return by reference. Note that it cannot be
  676.       --  part of the normal semantic analysis of the spec since the
  677.       --  underlying returned type may not be known yet (for private types)
  678.  
  679.       declare
  680.          Typ  : constant Entity_Id := Etype (E);
  681.          Utyp : constant Entity_Id := Underlying_Type (Typ);
  682.  
  683.       begin
  684.          if Is_Return_By_Reference_Type (Typ) then
  685.             Set_Returns_By_Ref (E);
  686.  
  687.          elsif Present (Utyp)
  688.            and then Is_Record_Type (Utyp)
  689.            and then Controlled_Type (Utyp)
  690.          then
  691.             Set_Returns_By_Ref (E);
  692.          end if;
  693.       end;
  694.  
  695.    end Freeze_Subprogram;
  696.  
  697. end Exp_Ch6;
  698.