1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Util; use Exp_Util;
31 with Restrict; use Restrict;
32 with Rident; use Rident;
33 with Sem_Aux; use Sem_Aux;
34 with Sem_Util; use Sem_Util;
35 with Sinfo; use Sinfo;
37 package body Exp_Tss is
43 function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
48 pragma Assert (Is_Type (Typ));
50 if Is_Private_Type (Typ) then
51 Full_Type := Underlying_Type (Base_Type (Typ));
56 if No (Full_Type) then
58 elsif Is_Concurrent_Type (Full_Type)
59 and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
61 -- The initialization routine to be called is that of the base type
62 -- of the corresponding record type, which may itself be a subtype
63 -- and possibly an itype.
66 (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))));
69 Proc := Init_Proc (Base_Type (Full_Type));
72 and then Is_Composite_Type (Full_Type)
73 and then Is_Derived_Type (Full_Type)
75 return Init_Proc (Root_Type (Full_Type));
86 -- Note: internally this routine is also used to initially set up
87 -- a TSS entry for a new type (case of being called from Set_TSS)
89 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
93 Ensure_Freeze_Node (Typ);
94 FN := Freeze_Node (Typ);
96 if No (TSS_Elist (FN)) then
97 Set_TSS_Elist (FN, New_Elmt_List);
100 -- We prepend here, so that a second call overrides the first, it
101 -- is not clear that this is required, but it seems reasonable.
103 Prepend_Elmt (TSS, TSS_Elist (FN));
106 ------------------------
107 -- Find_Inherited_TSS --
108 ------------------------
110 function Find_Inherited_TSS
112 Nam : TSS_Name_Type) return Entity_Id
114 Btyp : Entity_Id := Typ;
119 Btyp := Base_Type (Btyp);
120 Proc := TSS (Btyp, Nam);
122 exit when Present (Proc)
123 or else not Is_Derived_Type (Btyp);
125 -- If Typ is a derived type, it may inherit attributes from some
128 Btyp := Etype (Btyp);
133 -- If nothing else, use the TSS of the root type
135 Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
139 end Find_Inherited_TSS;
141 -----------------------
142 -- Get_TSS_Name_Type --
143 -----------------------
145 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
151 Get_Last_Two_Chars (Chars (E), C1, C2);
153 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
156 for J in TSS_Names'Range loop
157 if Nm = TSS_Names (J) then
166 ---------------------------------
167 -- Has_Non_Null_Base_Init_Proc --
168 ---------------------------------
170 -- Note: if a base Init_Proc is present, and No_Default_Initialization is
171 -- present, then we must avoid testing for a null init proc, since there
172 -- is no init proc present in this case.
174 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
175 BIP : constant Entity_Id := Base_Init_Proc (Typ);
178 and then (Restriction_Active (No_Default_Initialization)
179 or else not Is_Null_Init_Proc (BIP));
180 end Has_Non_Null_Base_Init_Proc;
186 function Init_Proc (Typ : Entity_Id) return Entity_Id is
187 FN : constant Node_Id := Freeze_Node (Typ);
194 elsif No (TSS_Elist (FN)) then
198 Elmt := First_Elmt (TSS_Elist (FN));
199 while Present (Elmt) loop
200 if Is_Init_Proc (Node (Elmt)) then
215 function Is_Init_Proc (E : Entity_Id) return Boolean is
219 Get_Last_Two_Chars (Chars (E), C1, C2);
220 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
227 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
231 Get_Last_Two_Chars (Chars (E), C1, C2);
232 return C1 = Nam (1) and then C2 = Nam (2);
235 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
239 Get_Last_Two_Chars (N, C1, C2);
240 return C1 = Nam (1) and then C2 = Nam (2);
243 -------------------------
244 -- Make_Init_Proc_Name --
245 -------------------------
247 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
249 return Make_TSS_Name (Typ, TSS_Init_Proc);
250 end Make_Init_Proc_Name;
256 function Make_TSS_Name
258 Nam : TSS_Name_Type) return Name_Id
261 Get_Name_String (Chars (Typ));
262 Add_Char_To_Name_Buffer (Nam (1));
263 Add_Char_To_Name_Buffer (Nam (2));
267 -------------------------
268 -- Make_TSS_Name_Local --
269 -------------------------
271 function Make_TSS_Name_Local
273 Nam : TSS_Name_Type) return Name_Id
276 Get_Name_String (Chars (Typ));
277 Add_Char_To_Name_Buffer ('_');
278 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
279 Add_Char_To_Name_Buffer (Nam (1));
280 Add_Char_To_Name_Buffer (Nam (2));
282 end Make_TSS_Name_Local;
288 function Same_TSS (E1, E2 : Entity_Id) return Boolean is
295 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
296 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
312 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
321 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
323 -- Make sure body of subprogram is frozen
325 -- Skip this for Init_Proc with No_Default_Initialization, since the
326 -- Init proc is a dummy void entity in this case to be ignored.
328 if Is_Init_Proc (TSS)
329 and then Restriction_Active (No_Default_Initialization)
333 -- Skip this if not in the same code unit (since it means we are using
334 -- an already existing TSS in another unit)
336 elsif not In_Same_Code_Unit (Typ, TSS) then
339 -- Otherwise make sure body is frozen
342 Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
354 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
355 FN : constant Node_Id := Freeze_Node (Typ);
363 elsif No (TSS_Elist (FN)) then
367 Elmt := First_Elmt (TSS_Elist (FN));
368 while Present (Elmt) loop
369 if Is_TSS (Node (Elmt), Nam) then
372 -- For stream subprograms, the TSS entity may be a renaming-
373 -- as-body of an already generated entity. Use that one rather
374 -- the one introduced by the renaming, which is an artifact of
375 -- current stream handling.
377 if Nkind (Parent (Parent (Subp))) =
378 N_Subprogram_Renaming_Declaration
380 Present (Corresponding_Spec (Parent (Parent (Subp))))
382 return Corresponding_Spec (Parent (Parent (Subp)));
396 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
397 FN : constant Node_Id := Freeze_Node (Typ);
405 elsif No (TSS_Elist (FN)) then
409 Elmt := First_Elmt (TSS_Elist (FN));
410 while Present (Elmt) loop
411 if Chars (Node (Elmt)) = Nam then
414 -- For stream subprograms, the TSS entity may be a renaming-
415 -- as-body of an already generated entity. Use that one rather
416 -- the one introduced by the renaming, which is an artifact of
417 -- current stream handling.
419 if Nkind (Parent (Parent (Subp))) =
420 N_Subprogram_Renaming_Declaration
422 Present (Corresponding_Spec (Parent (Parent (Subp))))
424 return Corresponding_Spec (Parent (Parent (Subp)));