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 / tbuild.adb < prev    next >
Text File  |  1996-09-28  |  8KB  |  256 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               T B U I L D                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.74 $                             --
  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 Errout;   use Errout;
  28. with Lib;      use Lib;
  29. with Lib.Writ; use Lib.Writ;
  30. with Namet;    use Namet;
  31. with Nlists;   use Nlists;
  32. with Nmake;    use Nmake;
  33. with Output;   use Output;
  34. with Sinfo;    use Sinfo;
  35. with Stand;    use Stand;
  36.  
  37. package body Tbuild is
  38.  
  39.    -----------------------
  40.    -- Local Subprograms --
  41.    -----------------------
  42.  
  43.    procedure Add_Nat_To_Name_Buffer (V : Nat);
  44.    --  Add decimal representation of given value to the end of the string
  45.    --  currently stored in Name_Buffer, incrementing Name_Len as required.
  46.  
  47.    ----------------------------
  48.    -- Add_Nat_To_Name_Buffer --
  49.    ----------------------------
  50.  
  51.    procedure Add_Nat_To_Name_Buffer (V : Nat) is
  52.    begin
  53.       if V >= 10 then
  54.          Add_Nat_To_Name_Buffer (V / 10);
  55.       end if;
  56.  
  57.       Name_Len := Name_Len + 1;
  58.       Name_Buffer (Name_Len) := Character'Val (Character'Pos ('0') + V rem 10);
  59.    end Add_Nat_To_Name_Buffer;
  60.  
  61.    -----------------------
  62.    -- Make_DT_Component --
  63.    -----------------------
  64.  
  65.    function Make_DT_Component
  66.      (Loc  : Source_Ptr;
  67.       Typ  : Entity_Id;
  68.       I    : Positive)
  69.       return Node_Id
  70.    is
  71.       X : Node_Id;
  72.       Full_Type : Entity_Id := Typ;
  73.  
  74.    begin
  75.       if Is_Private_Type (Typ) then
  76.          Full_Type := Underlying_Type (Typ);
  77.       end if;
  78.  
  79.       X := First_Component (
  80.              Designated_Type (Etype (Access_Disp_Table (Full_Type))));
  81.  
  82.       for J in 2 .. I loop
  83.          X := Next_Component (X);
  84.       end loop;
  85.  
  86.       return New_Reference_To (X, Loc);
  87.    end Make_DT_Component;
  88.  
  89.    --------------------
  90.    -- Make_DT_Access --
  91.    --------------------
  92.  
  93.    function Make_DT_Access
  94.      (Loc  : Source_Ptr;
  95.       Rec  : Node_Id;
  96.       Typ  : Entity_Id)
  97.       return Node_Id
  98.    is
  99.       Full_Type : Entity_Id := Typ;
  100.  
  101.    begin
  102.       if Is_Private_Type (Typ) then
  103.          Full_Type := Underlying_Type (Typ);
  104.       end if;
  105.  
  106.       return
  107.         Make_Unchecked_Type_Conversion (Loc,
  108.           Subtype_Mark =>
  109.             New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
  110.           Expression =>
  111.             Make_Selected_Component (Loc,
  112.               Prefix => New_Copy (Rec),
  113.               Selector_Name =>
  114.                 New_Reference_To (Tag_Component (Full_Type), Loc)));
  115.    end Make_DT_Access;
  116.  
  117.    --------------------------
  118.    -- New_Constraint_Error --
  119.    --------------------------
  120.  
  121.    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
  122.       Ident_Node : Node_Id;
  123.       Raise_Node : Node_Id;
  124.  
  125.    begin
  126.       Ident_Node := New_Node (N_Identifier, Loc);
  127.       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
  128.       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
  129.       Raise_Node := New_Node (N_Raise_Statement, Loc);
  130.       Set_Name (Raise_Node, Ident_Node);
  131.       return Raise_Node;
  132.    end New_Constraint_Error;
  133.  
  134.    -----------------------
  135.    -- New_External_Name --
  136.    -----------------------
  137.  
  138.    function New_External_Name
  139.      (Related_Id   : Name_Id;
  140.       Suffix       : Character := ' ';
  141.       Suffix_Index : Nat       := 0;
  142.       Prefix       : Character := ' ')
  143.       return         Name_Id
  144.    is
  145.    begin
  146.       pragma Assert (Is_OK_Internal_Letter (Suffix));
  147.       Get_Name_String (Related_Id);
  148.  
  149.       if Prefix /= ' ' then
  150.          pragma Assert (Is_OK_Internal_Letter (Prefix));
  151.  
  152.          for J in reverse 1 .. Name_Len loop
  153.             Name_Buffer (J + 1) := Name_Buffer (J);
  154.          end loop;
  155.  
  156.          Name_Len := Name_Len + 1;
  157.          Name_Buffer (1) := Prefix;
  158.       end if;
  159.  
  160.       Name_Len := Name_Len + 1;
  161.       Name_Buffer (Name_Len) := Suffix;
  162.  
  163.       if Suffix_Index /= 0 then
  164.          Add_Nat_To_Name_Buffer (Suffix_Index);
  165.       end if;
  166.  
  167.       return Name_Find;
  168.    end New_External_Name;
  169.  
  170.    function New_External_Name
  171.      (Suffix       : Character;
  172.       Suffix_Index : Nat)
  173.       return         Name_Id
  174.    is
  175.    begin
  176.       Name_Buffer (1) := Suffix;
  177.       Name_Len := 1;
  178.       Add_Nat_To_Name_Buffer (Suffix_Index);
  179.       return Name_Find;
  180.    end New_External_Name;
  181.  
  182.    -----------------------
  183.    -- New_Internal_Name --
  184.    -----------------------
  185.  
  186.    function New_Internal_Name (Id_Char : Character) return Name_Id is
  187.       Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
  188.  
  189.    begin
  190.       pragma Assert (Is_OK_Internal_Letter (Id_Char));
  191.       Name_Buffer (1) := Id_Char;
  192.       Name_Len := 1;
  193.       Add_Nat_To_Name_Buffer (Increment_Serial_Number);
  194.  
  195.       --  Add either b or s, depending on whether current unit is a spec
  196.       --  or a body. This is needed because we may generate the same name
  197.       --  in a spec and a body otherwise.
  198.  
  199.       Name_Len := Name_Len + 1;
  200.  
  201.       if Nkind (Unit_Node) = N_Package_Declaration or else
  202.          Nkind (Unit_Node) = N_Subprogram_Declaration
  203.       then
  204.          Name_Buffer (Name_Len) := 's';
  205.       else
  206.          Name_Buffer (Name_Len) := 'b';
  207.       end if;
  208.  
  209.       return Name_Enter;
  210.    end New_Internal_Name;
  211.  
  212.    -----------------------
  213.    -- New_Occurrence_Of --
  214.    -----------------------
  215.  
  216.    function New_Occurrence_Of
  217.      (Def_Id : Entity_Id;
  218.       Loc    : Source_Ptr)
  219.       return   Node_Id
  220.    is
  221.       Occurrence : Node_Id;
  222.  
  223.    begin
  224.       Occurrence := New_Node (N_Identifier, Loc);
  225.       Set_Chars (Occurrence, Chars (Def_Id));
  226.       Set_Entity (Occurrence, Def_Id);
  227.  
  228.       if Is_Type (Def_Id) then
  229.          Set_Etype (Occurrence, Def_Id);
  230.       else
  231.          Set_Etype (Occurrence, Etype (Def_Id));
  232.       end if;
  233.  
  234.       return Occurrence;
  235.    end New_Occurrence_Of;
  236.  
  237.    ----------------------
  238.    -- New_Reference_To --
  239.    ----------------------
  240.  
  241.    function New_Reference_To
  242.      (Def_Id : Entity_Id;
  243.       Loc    : Source_Ptr)
  244.       return   Node_Id
  245.    is
  246.       Occurrence : Node_Id;
  247.  
  248.    begin
  249.       Occurrence := New_Node (N_Identifier, Loc);
  250.       Set_Chars (Occurrence, Chars (Def_Id));
  251.       Set_Entity (Occurrence, Def_Id);
  252.       return Occurrence;
  253.    end New_Reference_To;
  254.  
  255. end Tbuild;
  256.