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_ch13.adb < prev    next >
Text File  |  1996-09-28  |  15KB  |  410 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             E X P _ C H 1 3                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.28 $                             --
  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_Ch3;  use Exp_Ch3;
  28. with Exp_Ch6;  use Exp_Ch6;
  29. with Exp_TSS;  use Exp_TSS;
  30. with Nlists;   use Nlists;
  31. with Nmake;    use Nmake;
  32. with Rtsfind;  use Rtsfind;
  33. with Sem;      use Sem;
  34. with Sem_Ch7;  use Sem_Ch7;
  35. with Sem_Ch8;  use Sem_Ch8;
  36. with Sem_Eval; use Sem_Eval;
  37. with Sem_Util; use Sem_Util;
  38. with Sinfo;    use Sinfo;
  39. with Snames;   use Snames;
  40. with Tbuild;   use Tbuild;
  41. with Uintp;    use Uintp;
  42.  
  43. package body Exp_Ch13 is
  44.  
  45.    ------------------------------------------
  46.    -- Expand_N_Attribute_Definition_Clause --
  47.    ------------------------------------------
  48.  
  49.    --  Expansion action depends on attribute involved
  50.  
  51.    procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
  52.       Loc : constant Source_Ptr := Sloc (N);
  53.       Exp : constant Node_Id    := Expression (N);
  54.       Ent : Entity_Id;
  55.       V   : Node_Id;
  56.  
  57.    begin
  58.       Ent := Entity (Name (N));
  59.  
  60.       if Is_Type (Ent) then
  61.          Ent := Underlying_Type (Ent);
  62.       end if;
  63.  
  64.       case Get_Attribute_Id (Chars (N)) is
  65.  
  66.       --  Alignment
  67.  
  68.       when Attribute_Alignment =>
  69.  
  70.          --  As required by Gigi, we guarantee that the operand is an
  71.          --  integer literal (this simplifies things in Gigi).
  72.  
  73.          if Nkind (Exp) /= N_Integer_Literal then
  74.             Rewrite_Substitute_Tree
  75.               (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
  76.          end if;
  77.  
  78.       --  Input attribute
  79.  
  80.       when Attribute_Input => Input : declare
  81.          Input_Ent  : Entity_Id;
  82.          Input_Decl : Node_Id;
  83.          F          : Entity_Id;
  84.          Subp       : Entity_Id;
  85.          Etyp       : Entity_Id;
  86.       begin
  87.  
  88.          Subp       := Entity (Exp);
  89.          F          := First_Formal (Subp);
  90.          Input_Ent  := Make_Defining_Identifier (Loc, Name_uInput);
  91.          Etyp       := Etype (Subp);
  92.          Input_Decl :=
  93.            Make_Subprogram_Renaming_Declaration (Loc,
  94.              Specification =>
  95.  
  96.                Make_Function_Specification (Loc,
  97.                  Defining_Unit_Name => Input_Ent,
  98.                  Parameter_Specifications =>
  99.                    New_List (
  100.                      Make_Parameter_Specification (Loc,
  101.                        Defining_Identifier =>
  102.                          Make_Defining_Identifier (Loc,
  103.                            Chars => New_Internal_Name ('S')),
  104.                        Parameter_Type =>
  105.                          Make_Access_Definition (Loc,
  106.                            Subtype_Mark =>
  107.                              New_Reference_To (
  108.                                Designated_Type (Etype (F)), Loc)))),
  109.  
  110.                  Subtype_Mark =>
  111.                    New_Reference_To (Etyp, Loc)),
  112.  
  113.              Name => New_Reference_To (Subp, Loc));
  114.  
  115.          if No (Freeze_Node (Ent)) then
  116.             Set_Freeze_Node (Ent, Make_Freeze_Entity (Loc));
  117.             Set_TSS_Elist (Freeze_Node (Ent), No_Elist);
  118.          end if;
  119.  
  120.          Set_TSS (Ent, Input_Ent);
  121.       end Input;
  122.  
  123.       --  Attribute Output
  124.  
  125.       when Attribute_Output => Output : declare
  126.          Output_Ent  : Entity_Id;
  127.          Output_Decl : Node_Id;
  128.          F           : Entity_Id;
  129.          Subp        : Entity_Id;
  130.          Etyp        : Entity_Id;
  131.  
  132.       begin
  133.          Subp        := Entity (Exp);
  134.          F           := First_Formal (Subp);
  135.          Output_Ent  := Make_Defining_Identifier (Loc, Name_uOutput);
  136.          Etyp        := Etype (Next_Formal (F));
  137.          Output_Decl :=
  138.            Make_Subprogram_Renaming_Declaration (Loc,
  139.              Specification =>
  140.  
  141.                Make_Procedure_Specification (Loc,
  142.                  Defining_Unit_Name => Output_Ent,
  143.                  Parameter_Specifications =>
  144.                    New_List (
  145.  
  146.                      Make_Parameter_Specification (Loc,
  147.                        Defining_Identifier =>
  148.                          Make_Defining_Identifier (Loc,
  149.                            Chars => New_Internal_Name ('S')),
  150.  
  151.                        Parameter_Type =>
  152.                          Make_Access_Definition (Loc,
  153.                            Subtype_Mark =>
  154.                              New_Reference_To (
  155.                                Designated_Type (Etype (F)), Loc))),
  156.  
  157.                      Make_Parameter_Specification (Loc,
  158.                        Defining_Identifier =>
  159.                          Make_Defining_Identifier (Loc,
  160.                            Chars => New_Internal_Name ('V')),
  161.                        Parameter_Type =>
  162.                          New_Reference_To (Etyp, Loc)))),
  163.  
  164.              Name => New_Reference_To (Subp, Loc));
  165.  
  166.          if No (Freeze_Node (Ent)) then
  167.             Set_Freeze_Node (Ent, Make_Freeze_Entity (Loc));
  168.             Set_TSS_Elist (Freeze_Node (Ent), No_Elist);
  169.          end if;
  170.  
  171.          Set_TSS (Ent, Output_Ent);
  172.       end Output;
  173.  
  174.       --  Read attribute
  175.  
  176.       when Attribute_Read => Read : declare
  177.          Read_Ent  : Entity_Id;
  178.          Read_Decl : Node_Id;
  179.          F         : Entity_Id;
  180.          Subp      : Entity_Id;
  181.          Etyp      : Entity_Id;
  182.  
  183.       begin
  184.          Subp      := Entity (Exp);
  185.          F         := First_Formal (Subp);
  186.          Read_Ent  := Make_Defining_Identifier (Loc, Name_uRead);
  187.          Etyp      := Etype (Next_Formal (F));
  188.          Read_Decl :=
  189.            Make_Subprogram_Renaming_Declaration (Loc,
  190.              Specification =>
  191.  
  192.                Make_Procedure_Specification (Loc,
  193.                  Defining_Unit_Name => Read_Ent,
  194.                  Parameter_Specifications =>
  195.                    New_List (
  196.  
  197.                      Make_Parameter_Specification (Loc,
  198.                        Defining_Identifier =>
  199.                          Make_Defining_Identifier (Loc,
  200.                            Chars => New_Internal_Name ('S')),
  201.                        Parameter_Type =>
  202.                          Make_Access_Definition (Loc,
  203.                            Subtype_Mark =>
  204.                              New_Reference_To (
  205.                                Designated_Type (Etype (F)), Loc))),
  206.  
  207.                      Make_Parameter_Specification (Loc,
  208.                        Defining_Identifier =>
  209.                          Make_Defining_Identifier (Loc,
  210.                            Chars => New_Internal_Name ('V')),
  211.                        Out_Present => True,
  212.                        Parameter_Type =>
  213.                          New_Reference_To (Etyp, Loc)))),
  214.  
  215.              Name => New_Reference_To (Subp, Loc));
  216.  
  217.          if No (Freeze_Node (Ent)) then
  218.             Set_Freeze_Node (Ent, Make_Freeze_Entity (Loc));
  219.             Set_TSS_Elist (Freeze_Node (Ent), No_Elist);
  220.          end if;
  221.  
  222.          Set_TSS (Ent, Read_Ent);
  223.       end Read;
  224.  
  225.       --  Storage_Size
  226.  
  227.       when Attribute_Storage_Size =>
  228.  
  229.          --  If the type is a task type, then assign the value of the
  230.          --  storage size to the Size variable associated with the task.
  231.          --    task_typeZ := expression
  232.  
  233.          if Ekind (Ent) = E_Task_Type then
  234.             Rewrite_Substitute_Tree (N,
  235.               Make_Assignment_Statement (Loc,
  236.                 Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
  237.  
  238.                 Expression =>
  239.                   Make_Type_Conversion (Loc,
  240.                     Subtype_Mark =>
  241.                       New_Reference_To (RTE (RE_Size_Type), Loc),
  242.                     Expression => Expression (N))));
  243.  
  244.                Analyze (N);
  245.  
  246.          --  For Storage_Size for an access type, create a variable to hold
  247.          --  the value of the specified size with name typeV and expand an
  248.          --  assignment statement to initialze this value.
  249.  
  250.          elsif Ekind (Ent) = E_Access_Type then
  251.  
  252.             V := Make_Defining_Identifier (Loc,
  253.                    New_External_Name (Chars (Ent), 'V'));
  254.  
  255.             Rewrite_Substitute_Tree (N,
  256.               Make_Object_Declaration (Loc,
  257.                 Defining_Identifier => V,
  258.                 Object_Definition  =>
  259.                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
  260.                 Expression =>
  261.                   Make_Type_Conversion (Loc,
  262.                     Subtype_Mark =>
  263.                       New_Reference_To (RTE (RE_Storage_Offset), Loc),
  264.                     Expression => Expression (N))));
  265.  
  266.             Analyze (N);
  267.             Set_Storage_Size_Variable (Ent, Entity_Id (V));
  268.          end if;
  269.  
  270.       --  Write attribute
  271.  
  272.       when Attribute_Write => Write : declare
  273.          Write_Ent  : Entity_Id;
  274.          Write_Decl : Node_Id;
  275.          F          : Entity_Id;
  276.          Subp       : Entity_Id;
  277.          Etyp       : Entity_Id;
  278.  
  279.       begin
  280.          Subp       := Entity (Exp);
  281.          F          := First_Formal (Subp);
  282.          Write_Ent  := Make_Defining_Identifier (Loc, Name_uWrite);
  283.          Etyp       := Etype (Next_Formal (F));
  284.          Write_Decl :=
  285.            Make_Subprogram_Renaming_Declaration (Loc,
  286.              Specification =>
  287.  
  288.                Make_Procedure_Specification (Loc,
  289.                  Defining_Unit_Name => Write_Ent,
  290.                  Parameter_Specifications =>
  291.                    New_List (
  292.  
  293.                      Make_Parameter_Specification (Loc,
  294.                        Defining_Identifier =>
  295.                          Make_Defining_Identifier (Loc,
  296.                            Chars => New_Internal_Name ('S')),
  297.                        Parameter_Type =>
  298.                          Make_Access_Definition (Loc,
  299.                            Subtype_Mark =>
  300.                              New_Reference_To (
  301.                                Designated_Type (Etype (F)), Loc))),
  302.  
  303.                      Make_Parameter_Specification (Loc,
  304.                        Defining_Identifier =>
  305.                          Make_Defining_Identifier (Loc,
  306.                            Chars => New_Internal_Name ('V')),
  307.                        Parameter_Type =>
  308.                          New_Reference_To (Etyp, Loc)))),
  309.  
  310.              Name => New_Reference_To (Subp, Loc));
  311.  
  312.          if No (Freeze_Node (Ent)) then
  313.             Set_Freeze_Node (Ent, Make_Freeze_Entity (Loc));
  314.             Set_TSS_Elist (Freeze_Node (Ent), No_Elist);
  315.          end if;
  316.  
  317.          Set_TSS (Ent, Write_Ent);
  318.       end Write;
  319.  
  320.          --  Other attributes require no expansion
  321.  
  322.          when others => null;
  323.  
  324.       end case;
  325.  
  326.    end Expand_N_Attribute_Definition_Clause;
  327.  
  328.    ----------------------------
  329.    -- Expand_N_Freeze_Entity --
  330.    ----------------------------
  331.  
  332.    procedure Expand_N_Freeze_Entity (N : Node_Id) is
  333.       E           : constant Entity_Id := Entity (N);
  334.       Inner_Scope : Boolean := False;
  335.  
  336.    begin
  337.       if not Is_Type (E) and then not Is_Subprogram (E) then
  338.          return;
  339.       end if;
  340.  
  341.       --  If the entity being frozen is defined in an inner package or task,
  342.       --  we must establish the proper visibility before freezing the
  343.       --  entity, and related subprograms.
  344.  
  345.       if Scope (Scope (E)) = Current_Scope then
  346.          New_Scope (Scope (E));
  347.          Install_Visible_Declarations (Scope (E));
  348.          Install_Private_Declarations (Scope (E));
  349.          Inner_Scope := True;
  350.       end if;
  351.  
  352.       --  If type, freeze the type
  353.  
  354.       if Is_Type (E) then
  355.          Freeze_Type (N);
  356.  
  357.       --  If subprogram, freeze the subprogram
  358.  
  359.       elsif Is_Subprogram (E) then
  360.          Freeze_Subprogram (N);
  361.  
  362.       --  No other entities require any front end freeze actions
  363.  
  364.       else
  365.          null;
  366.       end if;
  367.  
  368.       --  Analyze actions generated by freezing.
  369.  
  370.       if Present (Actions (N)) then
  371.          Analyze_List (Actions (N));
  372.       end if;
  373.  
  374.       if Inner_Scope then
  375.          if Ekind (Current_Scope) = E_Package then
  376.             End_Package_Scope (Scope (E));
  377.          else
  378.             End_Scope;
  379.          end if;
  380.       end if;
  381.    end Expand_N_Freeze_Entity;
  382.  
  383.    -------------------------------------------
  384.    -- Expand_N_Record_Representation_Clause --
  385.    -------------------------------------------
  386.  
  387.    --  The only expansion required is for the case of a mod clause present,
  388.    --  which is removed, and translated into an alignment representation
  389.    --  clause inserted immediately after the record rep clause.
  390.  
  391.    procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
  392.       Loc     : constant Source_Ptr := Sloc (N);
  393.       Rectype : constant Entity_Id  := Entity (Identifier (N));
  394.       Mod_Val : Uint;
  395.  
  396.    begin
  397.       if Present (Mod_Clause (N)) then
  398.          Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
  399.          Set_Mod_Clause (N, Empty);
  400.  
  401.          Insert_After (N,
  402.            Make_Attribute_Definition_Clause (Loc,
  403.              Name       => New_Reference_To (Rectype, Loc),
  404.              Chars      => Name_Alignment,
  405.              Expression => Make_Integer_Literal (Loc, Mod_Val)));
  406.       end if;
  407.    end Expand_N_Record_Representation_Clause;
  408.  
  409. end Exp_Ch13;
  410.