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
)));