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_intr.adb < prev    next >
Text File  |  1996-09-28  |  9KB  |  229 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             E X P _ I N T R                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.17 $                             --
  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 Einfo;    use Einfo;
  27. with Exp_Ch7;  use Exp_Ch7;
  28. with Exp_Fixd; use Exp_Fixd;
  29. with Exp_Util; use Exp_Util;
  30. with Nmake;    use Nmake;
  31. with Nlists;   use Nlists;
  32. with Rtsfind;  use Rtsfind;
  33. with Sem;      use Sem;
  34. with Sem_Util; use Sem_Util;
  35. with Sinfo;    use Sinfo;
  36. with Snames;   use Snames;
  37. with Stand;    use Stand;
  38. with Tbuild;   use Tbuild;
  39.  
  40. package body Exp_Intr is
  41.  
  42.    -----------------------
  43.    -- Local Subprograms --
  44.    -----------------------
  45.  
  46.    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
  47.    --  Expand an intrinsic shift operation, N and E are from the call to
  48.    --  Expand_Instrinsic_Call (call node and subprogram spec entity) and
  49.    --  K is the kind for the shift node
  50.  
  51.    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
  52.    --  Expand a call to an instantiation of Unchecked_Convertion into a node
  53.    --  N_Unchecked_Type_Conversion.
  54.  
  55.    procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id);
  56.    --  Expand a call to an instantiation of Unchecked_Deallocation into a node
  57.    --  N_Free_Statement and appropriate context.
  58.  
  59.    ----------------------------
  60.    -- Expand_Instrinsic_Call --
  61.    ----------------------------
  62.  
  63.    procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
  64.       Nam : Name_Id;
  65.  
  66.    begin
  67.       --  If the intrinsic subprogram is generic, gets its original name.
  68.  
  69.       if Present (Parent (E))
  70.         and then Present (Generic_Parent (Parent (E)))
  71.       then
  72.          Nam := Chars (Generic_Parent (Parent (E)));
  73.       else
  74.          Nam := Chars (E);
  75.       end if;
  76.  
  77.       if Nam = Name_Divide then
  78.          Expand_Decimal_Divide_Call (N);
  79.       elsif Nam = Name_Rotate_Left then
  80.          Expand_Shift (N, E, N_Op_Rotate_Left);
  81.       elsif Nam = Name_Rotate_Right then
  82.          Expand_Shift (N, E, N_Op_Rotate_Right);
  83.       elsif Nam = Name_Shift_Left then
  84.          Expand_Shift (N, E, N_Op_Shift_Left);
  85.       elsif Nam = Name_Shift_Right then
  86.          Expand_Shift (N, E, N_Op_Shift_Right);
  87.       elsif Nam = Name_Shift_Right_Arithmetic then
  88.          Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
  89.       elsif Nam = Name_Unchecked_Conversion then
  90.          Expand_Unc_Conversion (N, E);
  91.       elsif Nam = Name_Unchecked_Deallocation then
  92.          Expand_Unc_Deallocation (N, E);
  93.       else
  94.          --  If the entity is a renaming, expand the call to the original
  95.          --  operation (which must be intrinsic).
  96.  
  97.          pragma Assert (Present (Alias (E)));
  98.          Expand_Intrinsic_Call (N,  Alias (E));
  99.       end if;
  100.  
  101.    end Expand_Intrinsic_Call;
  102.  
  103.    ------------------
  104.    -- Expand_Shift --
  105.    ------------------
  106.  
  107.    --  This procedure is used to convert a call to a shift function to the
  108.    --  corresponding operator node. This conversion is not done by the usual
  109.    --  circuit for converting calls to operator functions (e.g. "+"(1,2)) to
  110.    --  operator nodes, because shifts are not predefined operators.
  111.  
  112.    --  As a result, whenever a shift is used in the source program, it will
  113.    --  remain as a call until converted by this routine to the operator node
  114.    --  form which Gigi is expecting to see.
  115.  
  116.    --  Note: it is possible for the expander to generate shift operator nodes
  117.    --  directly, which will be analyzed in the normal manner by calling Analyze
  118.    --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
  119.  
  120.    procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
  121.       Loc   : constant Source_Ptr := Sloc (N);
  122.       Typ   : constant Entity_Id  := Etype (N);
  123.       Left  : constant Node_Id    := First_Actual (N);
  124.       Right : constant Node_Id    := Next_Actual (Left);
  125.       Snode : Node_Id;
  126.  
  127.    begin
  128.       Snode := New_Node (K, Loc);
  129.       Set_Left_Opnd  (Snode, Relocate_Node (Left));
  130.       Set_Right_Opnd (Snode, Relocate_Node (Right));
  131.       Set_Chars      (Snode, Chars (E));
  132.       Set_Etype      (Snode, Base_Type (Typ));
  133.       Set_Entity     (Snode, E);
  134.  
  135.       --  Do the replacement. Note that we don't call Analyze and Resolve
  136.       --  on this node, because it already got analyzed and resolved when
  137.       --  it was a function call!
  138.  
  139.       Replace_Substitute_Tree (N, Snode);
  140.       Set_Analyzed (N);
  141.  
  142.    end Expand_Shift;
  143.  
  144.    ---------------------------
  145.    -- Expand_Unc_Conversion --
  146.    ---------------------------
  147.  
  148.    procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
  149.       Loc : constant Source_Ptr := Sloc (N);
  150.  
  151.    begin
  152.       Replace_Substitute_Tree (N,
  153.         Make_Unchecked_Type_Conversion (Loc,
  154.           Subtype_Mark => New_Occurrence_Of (Etype (E), Loc),
  155.           Expression   => Relocate_Node (First_Actual (N))));
  156.  
  157.       Set_Etype (N, Etype (E));
  158.       Set_Analyzed (N);
  159.    end Expand_Unc_Conversion;
  160.  
  161.    -----------------------------
  162.    -- Expand_Unc_Deallocation --
  163.    -----------------------------
  164.  
  165.    --  Generate the following Code :
  166.    --    if Arg /= null then
  167.    --
  168.    --       <Finalize_Call> (Arg.all);    -- for controlled types
  169.    --       Free (Arg);
  170.    --       Arg := Null;
  171.    --    end if;
  172.  
  173.    procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id) is
  174.       use Multi_Use;
  175.  
  176.       Loc       : constant Source_Ptr := Sloc (N);
  177.       Arg       : constant Node_Id    := First_Actual (N);
  178.       Typ       : constant Entity_Id  := Etype (Arg);
  179.       Stmts     : constant List_Id    := New_List;
  180.       Desig_T   : constant Entity_Id  := Designated_Type (Typ);
  181.       E_Arg     : Exp_Id;
  182.       Free_Node : Node_Id;
  183.       Exp       : Node_Id;
  184.  
  185.    begin
  186.       Multi_Use.New_Exp_Id (Arg, N, E_Arg);
  187.  
  188.       if Controlled_Type (Desig_T) then
  189.          Append_List_To (Stmts,
  190.            Make_Final_Call (
  191.              Ref         =>
  192.                Make_Explicit_Dereference (Loc, Multi_Use.New_Ref (E_Arg)),
  193.              Typ         => Desig_T,
  194.              Flist_Ref   => Find_Final_List (Typ),
  195.              With_Detach => New_Reference_To (Standard_True, Loc)));
  196.       end if;
  197.  
  198.       Free_Node :=
  199.         Make_Free_Statement (Loc,
  200.           Expression => Multi_Use.New_Ref (E_Arg));
  201.  
  202.       Set_Storage_Pool (Free_Node, Associated_Storage_Pool (Etype (Arg)));
  203.  
  204.       if Present (Storage_Pool (Free_Node)) then
  205.          Set_Procedure_To_Call (Free_Node,
  206.            Find_Prim_Op (Etype (Storage_Pool (Free_Node)), Name_Deallocate));
  207.       end if;
  208.  
  209.       Append_To (Stmts, Free_Node);
  210.  
  211.       Append_To (Stmts,
  212.         Make_Assignment_Statement (Loc,
  213.           Name       => Multi_Use.New_Ref (E_Arg),
  214.           Expression => Make_Null (Loc)));
  215.  
  216.       Replace_Substitute_Tree (N,
  217.         Make_If_Statement (Loc,
  218.           Condition =>
  219.             Make_Op_Ne (Loc,
  220.               Left_Opnd  => Multi_Use.New_Ref (E_Arg),
  221.               Right_Opnd => Make_Null (Loc)),
  222.  
  223.           Then_Statements => Stmts));
  224.  
  225.       Analyze (N);
  226.    end Expand_Unc_Deallocation;
  227.  
  228. end Exp_Intr;
  229.