diff options
author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
---|---|---|
committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:08:34 -0400 |
commit | 70482933d8f6a73b660f4cfa97b5c7c9deaf152e (patch) | |
tree | 133a71d6793865f2028234c0125afcfa4c7afc76 /gcc/ada/exp_tss.adb | |
parent | d23b8f573b3dcbfc04d13387885059de809aec50 (diff) | |
download | gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.zip gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.gz gcc-70482933d8f6a73b660f4cfa97b5c7c9deaf152e.tar.bz2 |
New Language: Ada
From-SVN: r45954
Diffstat (limited to 'gcc/ada/exp_tss.adb')
-rw-r--r-- | gcc/ada/exp_tss.adb | 200 |
1 files changed, 200 insertions, 0 deletions
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb new file mode 100644 index 0000000..6e3722c --- /dev/null +++ b/gcc/ada/exp_tss.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ T S S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.26 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; + +package body Exp_Tss is + + -------------------- + -- Base_Init_Proc -- + -------------------- + + function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is + Full_Type : E; + Proc : Entity_Id; + + begin + pragma Assert (Ekind (Typ) in Type_Kind); + + if Is_Private_Type (Typ) then + Full_Type := Underlying_Type (Base_Type (Typ)); + else + Full_Type := Typ; + end if; + + if No (Full_Type) then + return Empty; + elsif Is_Concurrent_Type (Full_Type) + and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) + then + return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type))); + + else + Proc := Init_Proc (Base_Type (Full_Type)); + + if No (Proc) + and then Is_Composite_Type (Full_Type) + and then Is_Derived_Type (Full_Type) + then + return Init_Proc (Root_Type (Full_Type)); + else + return Proc; + end if; + end if; + end Base_Init_Proc; + + -------------- + -- Copy_TSS -- + -------------- + + -- Note: internally this routine is also used to initially set up + -- a TSS entry for a new type (case of being called from Set_TSS) + + procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is + FN : Node_Id; + + begin + Ensure_Freeze_Node (Typ); + FN := Freeze_Node (Typ); + + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; + + -- We prepend here, so that a second call overrides the first, it + -- is not clear that this is required, but it seems reasonable. + + Prepend_Elmt (TSS, TSS_Elist (FN)); + end Copy_TSS; + + --------------------------------- + -- Has_Non_Null_Base_Init_Proc -- + --------------------------------- + + function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is + BIP : constant Entity_Id := Base_Init_Proc (Typ); + + begin + return Present (BIP) and then not Is_Null_Init_Proc (BIP); + end Has_Non_Null_Base_Init_Proc; + + --------------- + -- Init_Proc -- + --------------- + + function Init_Proc (Typ : Entity_Id) return Entity_Id is + begin + return TSS (Typ, Name_uInit_Proc); + end Init_Proc; + + ------------------- + -- Set_Init_Proc -- + ------------------- + + procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is + begin + Set_TSS (Typ, Init); + end Set_Init_Proc; + + ------------- + -- Set_TSS -- + ------------- + + procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is + Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS); + + begin + -- Case of insertion location is in unit defining the type + + if In_Same_Code_Unit (Typ, TSS) then + Append_Freeze_Action (Typ, Subprog_Body); + + -- Otherwise, we are using an already existing TSS in another unit + + else + null; + end if; + + Copy_TSS (TSS, Typ); + end Set_TSS; + + --------- + -- TSS -- + --------- + + function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is + FN : constant Node_Id := Freeze_Node (Typ); + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + if No (FN) then + return Empty; + + elsif No (TSS_Elist (FN)) then + return Empty; + + else + Elmt := First_Elmt (TSS_Elist (FN)); + + while Present (Elmt) loop + if Chars (Node (Elmt)) = Nam then + Subp := Node (Elmt); + + -- For stream subprograms, the TSS entity may be a renaming- + -- as-body of an already generated entity. Use that one rather + -- the one introduced by the renaming, which is an artifact of + -- current stream handling. + + if Nkind (Parent (Parent (Subp))) = + N_Subprogram_Renaming_Declaration + and then + Present (Corresponding_Spec (Parent (Parent (Subp)))) + then + return Corresponding_Spec (Parent (Parent (Subp))); + else + return Subp; + end if; + + else + Next_Elmt (Elmt); + end if; + end loop; + end if; + + return Empty; + end TSS; + +end Exp_Tss; |