1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Util; use Exp_Util;
32 with Namet; use Namet;
33 with Sem_Util; use Sem_Util;
34 with Sinfo; use Sinfo;
36 package body Exp_Tss is
42 function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
47 pragma Assert (Ekind (Typ) in Type_Kind);
49 if Is_Private_Type (Typ) then
50 Full_Type := Underlying_Type (Base_Type (Typ));
55 if No (Full_Type) then
57 elsif Is_Concurrent_Type (Full_Type)
58 and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
60 return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
63 Proc := Init_Proc (Base_Type (Full_Type));
66 and then Is_Composite_Type (Full_Type)
67 and then Is_Derived_Type (Full_Type)
69 return Init_Proc (Root_Type (Full_Type));
80 -- Note: internally this routine is also used to initially set up
81 -- a TSS entry for a new type (case of being called from Set_TSS)
83 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
87 Ensure_Freeze_Node (Typ);
88 FN := Freeze_Node (Typ);
90 if No (TSS_Elist (FN)) then
91 Set_TSS_Elist (FN, New_Elmt_List);
94 -- We prepend here, so that a second call overrides the first, it
95 -- is not clear that this is required, but it seems reasonable.
97 Prepend_Elmt (TSS, TSS_Elist (FN));
100 -----------------------
101 -- Get_TSS_Name_Type --
102 -----------------------
104 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
110 Get_Last_Two_Chars (Chars (E), C1, C2);
112 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
115 for J in OK_TSS_Names'Range loop
116 if Nm = OK_TSS_Names (J) then
125 ---------------------------------
126 -- Has_Non_Null_Base_Init_Proc --
127 ---------------------------------
129 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
130 BIP : constant Entity_Id := Base_Init_Proc (Typ);
133 return Present (BIP) and then not Is_Null_Init_Proc (BIP);
134 end Has_Non_Null_Base_Init_Proc;
140 function Init_Proc (Typ : Entity_Id) return Entity_Id is
141 FN : constant Node_Id := Freeze_Node (Typ);
148 elsif No (TSS_Elist (FN)) then
152 Elmt := First_Elmt (TSS_Elist (FN));
153 while Present (Elmt) loop
154 if Is_Init_Proc (Node (Elmt)) then
169 function Is_Init_Proc (E : Entity_Id) return Boolean is
173 Get_Last_Two_Chars (Chars (E), C1, C2);
174 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
181 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
185 Get_Last_Two_Chars (Chars (E), C1, C2);
186 return C1 = Nam (1) and then C2 = Nam (2);
189 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
193 Get_Last_Two_Chars (N, C1, C2);
194 return C1 = Nam (1) and then C2 = Nam (2);
197 -------------------------
198 -- Make_Init_Proc_Name --
199 -------------------------
201 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
203 Get_Name_String (Chars (Typ));
204 Name_Len := Name_Len + 2;
205 Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1);
206 Name_Buffer (Name_Len) := TSS_Init_Proc (2);
208 end Make_Init_Proc_Name;
210 -------------------------
211 -- Make_TSS_Name_Local --
212 -------------------------
214 function Make_TSS_Name_Local
216 Nam : TSS_Name_Type) return Name_Id
219 Get_Name_String (Chars (Typ));
220 Add_Char_To_Name_Buffer (Nam (1));
221 Add_Char_To_Name_Buffer (Nam (2));
222 Add_Char_To_Name_Buffer ('_');
223 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
225 end Make_TSS_Name_Local;
231 function Make_TSS_Name
233 Nam : TSS_Name_Type) return Name_Id
236 Get_Name_String (Chars (Typ));
237 Add_Char_To_Name_Buffer (Nam (1));
238 Add_Char_To_Name_Buffer (Nam (2));
246 function Same_TSS (E1, E2 : Entity_Id) return Boolean is
253 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
254 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
270 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
279 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
280 Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
283 -- Case of insertion location is in unit defining the type
285 if In_Same_Code_Unit (Typ, TSS) then
286 Append_Freeze_Action (Typ, Subprog_Body);
288 -- Otherwise, we are using an already existing TSS in another unit
301 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
302 FN : constant Node_Id := Freeze_Node (Typ);
310 elsif No (TSS_Elist (FN)) then
314 Elmt := First_Elmt (TSS_Elist (FN));
315 while Present (Elmt) loop
316 if Is_TSS (Node (Elmt), Nam) then
319 -- For stream subprograms, the TSS entity may be a renaming-
320 -- as-body of an already generated entity. Use that one rather
321 -- the one introduced by the renaming, which is an artifact of
322 -- current stream handling.
324 if Nkind (Parent (Parent (Subp))) =
325 N_Subprogram_Renaming_Declaration
327 Present (Corresponding_Spec (Parent (Parent (Subp))))
329 return Corresponding_Spec (Parent (Parent (Subp)));
343 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
344 FN : constant Node_Id := Freeze_Node (Typ);
352 elsif No (TSS_Elist (FN)) then
356 Elmt := First_Elmt (TSS_Elist (FN));
357 while Present (Elmt) loop
358 if Chars (Node (Elmt)) = Nam then
361 -- For stream subprograms, the TSS entity may be a renaming-
362 -- as-body of an already generated entity. Use that one rather
363 -- the one introduced by the renaming, which is an artifact of
364 -- current stream handling.
366 if Nkind (Parent (Parent (Subp))) =
367 N_Subprogram_Renaming_Declaration
369 Present (Corresponding_Spec (Parent (Parent (Subp))))
371 return Corresponding_Spec (Parent (Parent (Subp)));