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_tss.adb < prev    next >
Text File  |  1996-09-28  |  5KB  |  160 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              E X P _ T S S                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.7 $                              --
  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 Exp_Util; use Exp_Util;
  29. with Lib;      use Lib;
  30. with Namet;    use Namet;
  31. with Nlists;   use Nlists;
  32. with Output;   use Output;
  33. with Sem;      use Sem;
  34. with Sinfo;    use Sinfo;
  35. with Snames;   use Snames;
  36.  
  37. package body Exp_TSS is
  38.  
  39.    --------------------
  40.    -- Base_Init_Proc --
  41.    --------------------
  42.  
  43.    function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
  44.       Full_Type : E;
  45.  
  46.    begin
  47.       pragma Assert (Ekind (Typ) in Type_Kind);
  48.  
  49.       if Is_Private_Type (Typ) then
  50.          Full_Type := Underlying_Type (Base_Type (Typ));
  51.       else
  52.          Full_Type := Typ;
  53.       end if;
  54.  
  55.       if No (Full_Type) then
  56.          return Empty;
  57.       elsif Is_Concurrent_Type (Full_Type) then
  58.          return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
  59.       else
  60.          return Init_Proc (Base_Type (Full_Type));
  61.       end if;
  62.    end Base_Init_Proc;
  63.  
  64.    --------------
  65.    -- Copy_TSS --
  66.    --------------
  67.  
  68.    --  Note: internally this routine is also used to initially set up
  69.    --  a TSS entry for a new type (case of being called from Set_TSS)
  70.  
  71.    procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
  72.       FN : constant Node_Id := Freeze_Node (Typ);
  73.  
  74.    begin
  75.       pragma Assert (Present (FN));
  76.  
  77.       if No (TSS_Elist (FN)) then
  78.          Set_TSS_Elist (FN, New_Elmt_List);
  79.       end if;
  80.  
  81.       --  We prepend here, so that a second call overrides the first, it
  82.       --  is not clear that this is required, but it seems reasonable.
  83.  
  84.       Prepend_Elmt (TSS, TSS_Elist (FN));
  85.    end Copy_TSS;
  86.  
  87.    ---------------
  88.    -- Init_Proc --
  89.    ---------------
  90.  
  91.    function Init_Proc (Typ : Entity_Id) return Entity_Id is
  92.    begin
  93.       return TSS (Typ, Name_uInit_Proc);
  94.    end Init_Proc;
  95.  
  96.    -------------------
  97.    -- Set_Init_Proc --
  98.    -------------------
  99.  
  100.    procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
  101.    begin
  102.       Set_TSS (Typ, Init);
  103.    end Set_Init_Proc;
  104.  
  105.    -------------
  106.    -- Set_TSS --
  107.    -------------
  108.  
  109.    procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
  110.       Subprog_Body : constant Node_Id := Parent (Declaration_Node (TSS));
  111.  
  112.    begin
  113.       --  Case of insertion location is in unit defining the type
  114.  
  115.       if Get_Sloc_Unit_Number (Sloc (Typ)) =
  116.          Get_Sloc_Unit_Number (Sloc (TSS))
  117.       then
  118.          Append_Freeze_Action (Typ, Subprog_Body);
  119.  
  120.       --  Otherwise, TBD ???
  121.  
  122.       else
  123.          pragma Assert (False); null;
  124.       end if;
  125.  
  126.       Copy_TSS (TSS, Typ);
  127.    end Set_TSS;
  128.  
  129.    ---------
  130.    -- TSS --
  131.    ---------
  132.  
  133.    function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
  134.       FN   : constant Node_Id := Freeze_Node (Typ);
  135.       Elmt : Elmt_Id;
  136.  
  137.    begin
  138.       if No (FN) then
  139.          return Empty;
  140.  
  141.       elsif No (TSS_Elist (FN)) then
  142.          return Empty;
  143.  
  144.       else
  145.          Elmt := First_Elmt (TSS_Elist (FN));
  146.  
  147.          while Present (Elmt) loop
  148.             if Chars (Node (Elmt)) = Nam then
  149.                return Node (Elmt);
  150.             else
  151.                Elmt := Next_Elmt (Elmt);
  152.             end if;
  153.          end loop;
  154.       end if;
  155.  
  156.       return Empty;
  157.    end TSS;
  158.  
  159. end Exp_TSS;
  160.