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_ch2.adb < prev    next >
Text File  |  1996-09-28  |  10KB  |  260 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              E X P _ C H 2                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.30 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 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 Elists;   use Elists;
  28. with Nmake;    use Nmake;
  29. with Sem;      use Sem;
  30. with Sem_Util; use Sem_Util;
  31. with Sinfo;    use Sinfo;
  32. with Tbuild;   use Tbuild;
  33. with Snames;   use Snames;
  34.  
  35. package body Exp_Ch2 is
  36.  
  37.    -----------------------
  38.    -- Local Subprograms --
  39.    -----------------------
  40.  
  41.    procedure Expand_Discriminant (N : Node_Id);
  42.    --  An occurence of a discriminant within a discriminated type is replaced
  43.    --  with the corresponding discriminal, that is to say the formal parameter
  44.    --  of the initialization procedure for the type that is associated with
  45.    --  that particular discriminant. This replacement is not performed for
  46.    --  discriminants of records that appear in constraints of component of the
  47.    --  record, because Gigi uses the discriminant name to retrieve its value.
  48.    --  In the other hand, it has to be performed for default expressions of
  49.    --  components because they are used in the record init procedure.  See
  50.    --  Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use.
  51.  
  52.    procedure Expand_Entry_Index_Parameter (N : Node_Id);
  53.    --  A reference to the identifier in the entry index specification
  54.    --  of a protected entry body is modified to a reference to a constant
  55.    --  definintion equal to the index of the entry family member being
  56.    --  called.  This constant is calculated as part of the elaboration
  57.    --  of the expanded code for the body, and is calculated from the
  58.    --  object-wide entry index returned by Next_Entry_Call.
  59.  
  60.    procedure Expand_Entry_Parameter (N : Node_Id);
  61.    --  A reference to an entry parameter is modified to be a reference to
  62.    --  the corresponding component of the entry parameter record that is
  63.    --  passed by the runtime to the accept body procedure
  64.  
  65.    procedure Expand_Formal (N : Node_Id);
  66.    --  A reference to a formal parameter of a protected subprogram is
  67.    --  expanded to the corresponding formal of the unprotected procedure
  68.    --  used to represent the protected subprogram within the protected object.
  69.  
  70.    procedure Expand_Protected_Private (N : Node_Id);
  71.    --  A reference to a private object of a protected type is expanded
  72.    --  to a component selected from the record used to implement
  73.    --  the protected object.  Such a record is passed to all operations
  74.    --  on a protected object in a parameter named _object.  Such an object
  75.    --  can be a left-hand side only within a protected procedure
  76.    --  (or entry, not yet implemented ???).
  77.  
  78.    -------------------------
  79.    -- Expand_Discriminant --
  80.    -------------------------
  81.  
  82.    procedure Expand_Discriminant (N : Node_Id) is
  83.       Scop     : constant Entity_Id := Scope (Entity (N));
  84.       P        : Node_Id := N;
  85.       Parent_P : Node_Id := Parent (P);
  86.  
  87.    begin
  88.       if Ekind (Scop) = E_Record_Type then
  89.  
  90.          --  Find the origin by walking up the tree till the component
  91.          --  declaration
  92.  
  93.          while Present (Parent_P)
  94.            and then Nkind (Parent_P) /= N_Component_Declaration
  95.          loop
  96.             P := Parent_P;
  97.             Parent_P := Parent (P);
  98.          end loop;
  99.  
  100.          --  If the discriminant reference was part of the default expression
  101.          --  it has to be 'discriminalized'
  102.  
  103.          if Present (Parent_P) and then P = Expression (Parent_P) then
  104.             Set_Entity (N, Discriminal (Entity (N)));
  105.          end if;
  106.  
  107.       else
  108.          Set_Entity (N, Discriminal (Entity (N)));
  109.       end if;
  110.    end Expand_Discriminant;
  111.  
  112.    ----------------------------------
  113.    -- Expand_Entry_Index_Parameter --
  114.    ----------------------------------
  115.  
  116.    procedure Expand_Entry_Index_Parameter (N : Node_Id) is
  117.    begin
  118.       Set_Entity (N, Entry_Index_Constant (Entity (N)));
  119.    end Expand_Entry_Index_Parameter;
  120.  
  121.    ----------------------------
  122.    -- Expand_Entry_Parameter --
  123.    ----------------------------
  124.  
  125.    procedure Expand_Entry_Parameter (N : Node_Id) is
  126.       Loc        : constant Source_Ptr := Sloc (N);
  127.       Ent_Formal : constant Entity_Id  := Entity (N);
  128.       Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);
  129.       Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);
  130.       Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);
  131.       Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));
  132.       P_Comp_Ref : Entity_Id;
  133.  
  134.    begin
  135.       --  What we need is a reference to the corresponding component of the
  136.       --  parameter record object. The Accept_Address field of the entry
  137.       --  entity references the address variable that contains the address
  138.       --  of the accept parameters record. We first have to do an unchecked
  139.       --  conversion to turn this into a pointer to the parameter record and
  140.       --  then we select the required parameter field.
  141.  
  142.       P_Comp_Ref :=
  143.         Make_Selected_Component (Loc,
  144.           Prefix =>
  145.             Make_Unchecked_Type_Conversion (Loc,
  146.               Subtype_Mark => New_Reference_To (Parm_Type, Loc),
  147.               Expression   => New_Reference_To (Addr_Ent,  Loc)),
  148.           Selector_Name =>
  149.             New_Reference_To (Entry_Component (Ent_Formal), Loc));
  150.  
  151.       --  For all types of parameters, the constructed parameter record
  152.       --  object contains a pointer to the parameter. Thus we must
  153.       --  dereference them to access them (this will often be redundant,
  154.       --  since the needed deference is implicit, but no harm is done by
  155.       --  making it explicit).
  156.  
  157.       Rewrite_Substitute_Tree (N,
  158.         Make_Explicit_Dereference (Loc, P_Comp_Ref));
  159.  
  160.       Analyze (N);
  161.    end Expand_Entry_Parameter;
  162.  
  163.    -------------------
  164.    -- Expand_Formal --
  165.    -------------------
  166.  
  167.    procedure Expand_Formal (N : Node_Id) is
  168.       Loc  : constant Source_Ptr := Sloc (N);
  169.       E    : constant Entity_Id  := Entity (N);
  170.       Subp : constant Entity_Id  := Scope (E);
  171.  
  172.    begin
  173.       if Is_Protected_Type (Scope (Subp))
  174.         and then Chars (Subp) /= Name_uInit_Proc
  175.         and then Present (Protected_Formal (E))
  176.       then
  177.          Set_Actual_Subtype (Protected_Formal (E), Actual_Subtype (E));
  178.          Set_Entity (N, Protected_Formal (E));
  179.       end if;
  180.    end Expand_Formal;
  181.  
  182.    ------------------------------
  183.    -- Expand_Protected_Private --
  184.    ------------------------------
  185.  
  186.    procedure Expand_Protected_Private (N : Node_Id) is
  187.       Loc : constant Source_Ptr := Sloc (N);
  188.       E   : constant Entity_Id  := Entity (N);
  189.       Op  : constant Node_Id    := Protected_Operation (E);
  190.  
  191.    begin
  192.       if Nkind (Op) /= N_Subprogram_Body
  193.         or else Ekind (Defining_Unit_Name (Specification (Op))) /= E_Function
  194.       then
  195.          Set_Ekind (Prival (E), E_Variable);
  196.       else
  197.          Set_Ekind (Prival (E), E_Constant);
  198.       end if;
  199.  
  200.       Set_Entity (N, Prival (E));
  201.    end Expand_Protected_Private;
  202.  
  203.    ----------------------------
  204.    -- Expand_N_Expanded_Name --
  205.    ----------------------------
  206.  
  207.    --  Performs discriminal and entry parameter replacement as described above
  208.  
  209.    procedure Expand_N_Expanded_Name (N : Node_Id) is
  210.       E : constant Entity_Id := Entity (N);
  211.  
  212.    begin
  213.       if Ekind (E) = E_Discriminant then
  214.          Expand_Discriminant (N);
  215.  
  216.       elsif Is_Entry_Formal (E) then
  217.          Expand_Entry_Parameter (N);
  218.  
  219.       elsif Ekind (E) = E_Component
  220.         and then Is_Protected_Private (E)
  221.       then
  222.          Expand_Protected_Private (N);
  223.  
  224.       elsif Ekind (E) = E_Entry_Index_Parameter then
  225.          Expand_Entry_Index_Parameter (N);
  226.  
  227.       elsif Ekind (E) in Formal_Kind then
  228.          Expand_Formal (N);
  229.       end if;
  230.    end Expand_N_Expanded_Name;
  231.  
  232.    -------------------------
  233.    -- Expand_N_Identifier --
  234.    -------------------------
  235.  
  236.    procedure Expand_N_Identifier (N : Node_Id) is
  237.       E : constant Entity_Id := Entity (N);
  238.  
  239.    begin
  240.       if Ekind (E) = E_Discriminant then
  241.          Expand_Discriminant (N);
  242.  
  243.       elsif Is_Entry_Formal (E) then
  244.          Expand_Entry_Parameter (N);
  245.  
  246.       elsif Ekind (E) = E_Component
  247.         and then Is_Protected_Private (E)
  248.       then
  249.          Expand_Protected_Private (N);
  250.  
  251.       elsif Ekind (E) = E_Entry_Index_Parameter then
  252.          Expand_Entry_Index_Parameter (N);
  253.  
  254.       elsif Ekind (E) in Formal_Kind then
  255.          Expand_Formal (N);
  256.       end if;
  257.    end Expand_N_Identifier;
  258.  
  259. end Exp_Ch2;
  260.