aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.7/gcc/ada/exp_tss.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.7/gcc/ada/exp_tss.adb')
-rw-r--r--gcc-4.7/gcc/ada/exp_tss.adb547
1 files changed, 547 insertions, 0 deletions
diff --git a/gcc-4.7/gcc/ada/exp_tss.adb b/gcc-4.7/gcc/ada/exp_tss.adb
new file mode 100644
index 000000000..8b19f9190
--- /dev/null
+++ b/gcc-4.7/gcc/ada/exp_tss.adb
@@ -0,0 +1,547 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E X P _ T S S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2010, 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 3, 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 COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
+with Lib; use Lib;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+
+package body Exp_Tss is
+
+ --------------------
+ -- Base_Init_Proc --
+ --------------------
+
+ function Base_Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id
+ is
+ Full_Type : E;
+ Proc : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Typ));
+
+ 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
+ -- The initialization routine to be called is that of the base type
+ -- of the corresponding record type, which may itself be a subtype
+ -- and possibly an itype.
+
+ return Init_Proc
+ (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
+ Ref);
+
+ else
+ Proc := Init_Proc (Base_Type (Full_Type), Ref);
+
+ 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), Ref);
+ 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;
+
+ -------------------
+ -- CPP_Init_Proc --
+ -------------------
+
+ function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id is
+ FN : constant Node_Id := Freeze_Node (Typ);
+ Elmt : Elmt_Id;
+
+ begin
+ if not Is_CPP_Class (Root_Type (Typ))
+ or else No (FN)
+ or else No (TSS_Elist (FN))
+ then
+ return Empty;
+
+ else
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_CPP_Init_Proc (Node (Elmt)) then
+ return Node (Elmt);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end CPP_Init_Proc;
+
+ ------------------------
+ -- Find_Inherited_TSS --
+ ------------------------
+
+ function Find_Inherited_TSS
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id
+ is
+ Btyp : Entity_Id := Typ;
+ Proc : Entity_Id;
+
+ begin
+ loop
+ Btyp := Base_Type (Btyp);
+ Proc := TSS (Btyp, Nam);
+
+ exit when Present (Proc)
+ or else not Is_Derived_Type (Btyp);
+
+ -- If Typ is a derived type, it may inherit attributes from some
+ -- ancestor.
+
+ Btyp := Etype (Btyp);
+ end loop;
+
+ if No (Proc) then
+
+ -- If nothing else, use the TSS of the root type
+
+ Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
+ end if;
+
+ return Proc;
+ end Find_Inherited_TSS;
+
+ -----------------------
+ -- Get_TSS_Name_Type --
+ -----------------------
+
+ function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
+ C1 : Character;
+ C2 : Character;
+ Nm : TSS_Name_Type;
+
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+
+ if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
+ Nm := (C1, C2);
+
+ for J in TSS_Names'Range loop
+ if Nm = TSS_Names (J) then
+ return Nm;
+ end if;
+ end loop;
+ end if;
+
+ return TSS_Null;
+ end Get_TSS_Name;
+
+ ---------------------------------
+ -- Has_Non_Null_Base_Init_Proc --
+ ---------------------------------
+
+ -- Note: if a base Init_Proc is present, and No_Default_Initialization is
+ -- present, then we must avoid testing for a null init proc, since there
+ -- is no init proc present in this case.
+
+ 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 (Restriction_Active (No_Default_Initialization)
+ or else not Is_Null_Init_Proc (BIP));
+ end Has_Non_Null_Base_Init_Proc;
+
+ ---------------
+ -- Init_Proc --
+ ---------------
+
+ function Init_Proc
+ (Typ : Entity_Id;
+ Ref : Entity_Id := Empty) return Entity_Id
+ is
+ FN : constant Node_Id := Freeze_Node (Typ);
+ Elmt : Elmt_Id;
+ E1 : Entity_Id;
+ E2 : Entity_Id;
+
+ begin
+ if No (FN) then
+ return Empty;
+
+ elsif No (TSS_Elist (FN)) then
+ return Empty;
+
+ elsif No (Ref) then
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_Init_Proc (Node (Elmt)) then
+ if not Is_CPP_Class (Typ) then
+ return Node (Elmt);
+
+ -- For CPP classes, we are looking for the default constructor,
+ -- and so we must skip any non-default constructor.
+
+ elsif
+ No (Next
+ (First
+ (Parameter_Specifications (Parent (Node (Elmt))))))
+ then
+ return Node (Elmt);
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Non-default constructors are currently supported only in the context
+ -- of interfacing with C++.
+
+ else pragma Assert (Is_CPP_Class (Typ));
+
+ -- Use the referenced function to locate the init_proc matching
+ -- the C++ constructor.
+
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_Init_Proc (Node (Elmt)) then
+ E1 := Next_Formal (First_Formal (Node (Elmt)));
+ E2 := First_Formal (Ref);
+ while Present (E1) and then Present (E2) loop
+ if Chars (E1) /= Chars (E2)
+ or else Ekind (E1) /= Ekind (E2)
+ then
+ exit;
+
+ elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
+ and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
+ and then Etype (E1) /= Etype (E2)
+ then
+ exit;
+
+ elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
+ and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
+ and then Directly_Designated_Type (Etype (E1))
+ /= Directly_Designated_Type (Etype (E2))
+ then
+ exit;
+ end if;
+
+ E1 := Next_Formal (E1);
+ E2 := Next_Formal (E2);
+ end loop;
+
+ if No (E1) and then No (E2) then
+ return Node (Elmt);
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Init_Proc;
+
+ ----------------------
+ -- Is_CPP_Init_Proc --
+ ----------------------
+
+ function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
+ end Is_CPP_Init_Proc;
+
+ ------------------
+ -- Is_Init_Proc --
+ ------------------
+
+ function Is_Init_Proc (E : Entity_Id) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
+ end Is_Init_Proc;
+
+ ------------
+ -- Is_TSS --
+ ------------
+
+ function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = Nam (1) and then C2 = Nam (2);
+ end Is_TSS;
+
+ function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (N, C1, C2);
+ return C1 = Nam (1) and then C2 = Nam (2);
+ end Is_TSS;
+
+ -------------------------
+ -- Make_Init_Proc_Name --
+ -------------------------
+
+ function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
+ begin
+ return Make_TSS_Name (Typ, TSS_Init_Proc);
+ end Make_Init_Proc_Name;
+
+ -------------------
+ -- Make_TSS_Name --
+ -------------------
+
+ function Make_TSS_Name
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id
+ is
+ begin
+ Get_Name_String (Chars (Typ));
+ Add_Char_To_Name_Buffer (Nam (1));
+ Add_Char_To_Name_Buffer (Nam (2));
+ return Name_Find;
+ end Make_TSS_Name;
+
+ -------------------------
+ -- Make_TSS_Name_Local --
+ -------------------------
+
+ function Make_TSS_Name_Local
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id
+ is
+ begin
+ Get_Name_String (Chars (Typ));
+ Add_Char_To_Name_Buffer ('_');
+ Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+ Add_Char_To_Name_Buffer (Nam (1));
+ Add_Char_To_Name_Buffer (Nam (2));
+ return Name_Find;
+ end Make_TSS_Name_Local;
+
+ --------------
+ -- Same_TSS --
+ --------------
+
+ function Same_TSS (E1, E2 : Entity_Id) return Boolean is
+ E1C1 : Character;
+ E1C2 : Character;
+ E2C1 : Character;
+ E2C2 : Character;
+
+ begin
+ Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
+ Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
+
+ return
+ E1C1 = E2C1
+ and then
+ E1C2 = E2C2
+ and then
+ E1C1 in 'A' .. 'Z'
+ and then
+ E1C2 in 'A' .. 'Z';
+ end Same_TSS;
+
+ -------------------
+ -- 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
+ begin
+ -- Make sure body of subprogram is frozen
+
+ -- Skip this for Init_Proc with No_Default_Initialization, since the
+ -- Init proc is a dummy void entity in this case to be ignored.
+
+ if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
+ and then Restriction_Active (No_Default_Initialization)
+ then
+ null;
+
+ -- Skip this if not in the same code unit (since it means we are using
+ -- an already existing TSS in another unit)
+
+ elsif not In_Same_Code_Unit (Typ, TSS) then
+ null;
+
+ -- Otherwise make sure body is frozen
+
+ else
+ Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
+ end if;
+
+ -- Set TSS entry
+
+ Copy_TSS (TSS, Typ);
+ end Set_TSS;
+
+ ---------
+ -- TSS --
+ ---------
+
+ function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) 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 Is_TSS (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;
+
+ 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;