1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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;
30 with Nlists; use Nlists;
32 with Restrict; use Restrict;
33 with Rident; use Rident;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Util; use Sem_Util;
36 with Sinfo; use Sinfo;
38 package body Exp_Tss is
44 function Base_Init_Proc
46 Ref : Entity_Id := Empty) return Entity_Id
52 pragma Assert (Is_Type (Typ));
54 if Is_Private_Type (Typ) then
55 Full_Type := Underlying_Type (Base_Type (Typ));
60 if No (Full_Type) then
63 elsif Is_Concurrent_Type (Full_Type)
64 and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
66 -- The initialization routine to be called is that of the base type
67 -- of the corresponding record type, which may itself be a subtype
68 -- and possibly an itype.
71 (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
75 Proc := Init_Proc (Base_Type (Full_Type), Ref);
78 and then Is_Composite_Type (Full_Type)
79 and then Is_Derived_Type (Full_Type)
81 return Init_Proc (Root_Type (Full_Type), Ref);
92 -- Note: internally this routine is also used to initially set up
93 -- a TSS entry for a new type (case of being called from Set_TSS)
95 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
99 Ensure_Freeze_Node (Typ);
100 FN := Freeze_Node (Typ);
102 if No (TSS_Elist (FN)) then
103 Set_TSS_Elist (FN, New_Elmt_List);
106 -- We prepend here, so that a second call overrides the first, it
107 -- is not clear that this is required, but it seems reasonable.
109 Prepend_Elmt (TSS, TSS_Elist (FN));
112 ------------------------
113 -- Find_Inherited_TSS --
114 ------------------------
116 function Find_Inherited_TSS
118 Nam : TSS_Name_Type) return Entity_Id
120 Btyp : Entity_Id := Typ;
125 Btyp := Base_Type (Btyp);
126 Proc := TSS (Btyp, Nam);
128 exit when Present (Proc)
129 or else not Is_Derived_Type (Btyp);
131 -- If Typ is a derived type, it may inherit attributes from some
134 Btyp := Etype (Btyp);
139 -- If nothing else, use the TSS of the root type
141 Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
145 end Find_Inherited_TSS;
147 -----------------------
148 -- Get_TSS_Name_Type --
149 -----------------------
151 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
157 Get_Last_Two_Chars (Chars (E), C1, C2);
159 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
162 for J in TSS_Names'Range loop
163 if Nm = TSS_Names (J) then
172 ---------------------------------
173 -- Has_Non_Null_Base_Init_Proc --
174 ---------------------------------
176 -- Note: if a base Init_Proc is present, and No_Default_Initialization is
177 -- present, then we must avoid testing for a null init proc, since there
178 -- is no init proc present in this case.
180 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
181 BIP : constant Entity_Id := Base_Init_Proc (Typ);
184 and then (Restriction_Active (No_Default_Initialization)
185 or else not Is_Null_Init_Proc (BIP));
186 end Has_Non_Null_Base_Init_Proc;
194 Ref : Entity_Id := Empty) return Entity_Id
196 FN : constant Node_Id := Freeze_Node (Typ);
205 elsif No (TSS_Elist (FN)) then
209 Elmt := First_Elmt (TSS_Elist (FN));
210 while Present (Elmt) loop
211 if Is_Init_Proc (Node (Elmt)) then
212 if not Is_CPP_Class (Typ) then
215 -- For CPP classes, we are looking for the default constructor,
216 -- and so we must skip any non-default constructor.
221 (Parameter_Specifications (Parent (Node (Elmt))))))
230 -- Non-default constructors are currently supported only in the context
231 -- of interfacing with C++.
233 else pragma Assert (Is_CPP_Class (Typ));
235 -- Use the referenced function to locate the init_proc matching
236 -- the C++ constructor.
238 Elmt := First_Elmt (TSS_Elist (FN));
239 while Present (Elmt) loop
240 if Is_Init_Proc (Node (Elmt)) then
241 E1 := Next_Formal (First_Formal (Node (Elmt)));
242 E2 := First_Formal (Ref);
243 while Present (E1) and then Present (E2) loop
244 if Chars (E1) /= Chars (E2)
245 or else Ekind (E1) /= Ekind (E2)
249 elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
250 and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
251 and then Etype (E1) /= Etype (E2)
255 elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
256 and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
257 and then Directly_Designated_Type (Etype (E1))
258 /= Directly_Designated_Type (Etype (E2))
263 E1 := Next_Formal (E1);
264 E2 := Next_Formal (E2);
267 if No (E1) and then No (E2) then
283 function Is_Init_Proc (E : Entity_Id) return Boolean is
287 Get_Last_Two_Chars (Chars (E), C1, C2);
288 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
295 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
299 Get_Last_Two_Chars (Chars (E), C1, C2);
300 return C1 = Nam (1) and then C2 = Nam (2);
303 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
307 Get_Last_Two_Chars (N, C1, C2);
308 return C1 = Nam (1) and then C2 = Nam (2);
311 -------------------------
312 -- Make_Init_Proc_Name --
313 -------------------------
315 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
317 return Make_TSS_Name (Typ, TSS_Init_Proc);
318 end Make_Init_Proc_Name;
324 function Make_TSS_Name
326 Nam : TSS_Name_Type) return Name_Id
329 Get_Name_String (Chars (Typ));
330 Add_Char_To_Name_Buffer (Nam (1));
331 Add_Char_To_Name_Buffer (Nam (2));
335 -------------------------
336 -- Make_TSS_Name_Local --
337 -------------------------
339 function Make_TSS_Name_Local
341 Nam : TSS_Name_Type) return Name_Id
344 Get_Name_String (Chars (Typ));
345 Add_Char_To_Name_Buffer ('_');
346 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
347 Add_Char_To_Name_Buffer (Nam (1));
348 Add_Char_To_Name_Buffer (Nam (2));
350 end Make_TSS_Name_Local;
356 function Same_TSS (E1, E2 : Entity_Id) return Boolean is
363 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
364 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
380 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
389 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
391 -- Make sure body of subprogram is frozen
393 -- Skip this for Init_Proc with No_Default_Initialization, since the
394 -- Init proc is a dummy void entity in this case to be ignored.
396 if Is_Init_Proc (TSS)
397 and then Restriction_Active (No_Default_Initialization)
401 -- Skip this if not in the same code unit (since it means we are using
402 -- an already existing TSS in another unit)
404 elsif not In_Same_Code_Unit (Typ, TSS) then
407 -- Otherwise make sure body is frozen
410 Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
422 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
423 FN : constant Node_Id := Freeze_Node (Typ);
431 elsif No (TSS_Elist (FN)) then
435 Elmt := First_Elmt (TSS_Elist (FN));
436 while Present (Elmt) loop
437 if Is_TSS (Node (Elmt), Nam) then
440 -- For stream subprograms, the TSS entity may be a renaming-
441 -- as-body of an already generated entity. Use that one rather
442 -- the one introduced by the renaming, which is an artifact of
443 -- current stream handling.
445 if Nkind (Parent (Parent (Subp))) =
446 N_Subprogram_Renaming_Declaration
448 Present (Corresponding_Spec (Parent (Parent (Subp))))
450 return Corresponding_Spec (Parent (Parent (Subp)));
464 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
465 FN : constant Node_Id := Freeze_Node (Typ);
473 elsif No (TSS_Elist (FN)) then
477 Elmt := First_Elmt (TSS_Elist (FN));
478 while Present (Elmt) loop
479 if Chars (Node (Elmt)) = Nam then
482 -- For stream subprograms, the TSS entity may be a renaming-
483 -- as-body of an already generated entity. Use that one rather
484 -- the one introduced by the renaming, which is an artifact of
485 -- current stream handling.
487 if Nkind (Parent (Parent (Subp))) =
488 N_Subprogram_Renaming_Declaration
490 Present (Corresponding_Spec (Parent (Parent (Subp))))
492 return Corresponding_Spec (Parent (Parent (Subp)));