1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              E X P _ T S S                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
10--                                                                          --
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.                                                      --
21--                                                                          --
22-- GNAT was originally developed  by the GNAT team at  New York University. --
23-- Extensive contributions were provided by Ada Core Technologies Inc.      --
24--                                                                          --
25------------------------------------------------------------------------------
26
27with Atree;    use Atree;
28with Einfo;    use Einfo;
29with Elists;   use Elists;
30with Exp_Util; use Exp_Util;
31with Lib;      use Lib;
32with Namet;    use Namet;
33with Sem_Util; use Sem_Util;
34with Sinfo;    use Sinfo;
35
36package body Exp_Tss is
37
38   --------------------
39   -- Base_Init_Proc --
40   --------------------
41
42   function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
43      Full_Type : E;
44      Proc      : Entity_Id;
45
46   begin
47      pragma Assert (Ekind (Typ) in Type_Kind);
48
49      if Is_Private_Type (Typ) then
50         Full_Type := Underlying_Type (Base_Type (Typ));
51      else
52         Full_Type := Typ;
53      end if;
54
55      if No (Full_Type) then
56         return Empty;
57      elsif Is_Concurrent_Type (Full_Type)
58        and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
59      then
60         return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
61
62      else
63         Proc := Init_Proc (Base_Type (Full_Type));
64
65         if No (Proc)
66           and then Is_Composite_Type (Full_Type)
67           and then Is_Derived_Type (Full_Type)
68         then
69            return Init_Proc (Root_Type (Full_Type));
70         else
71            return Proc;
72         end if;
73      end if;
74   end Base_Init_Proc;
75
76   --------------
77   -- Copy_TSS --
78   --------------
79
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)
82
83   procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
84      FN : Node_Id;
85
86   begin
87      Ensure_Freeze_Node (Typ);
88      FN := Freeze_Node (Typ);
89
90      if No (TSS_Elist (FN)) then
91         Set_TSS_Elist (FN, New_Elmt_List);
92      end if;
93
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.
96
97      Prepend_Elmt (TSS, TSS_Elist (FN));
98   end Copy_TSS;
99
100   -----------------------
101   -- Get_TSS_Name_Type --
102   -----------------------
103
104   function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
105      C1 : Character;
106      C2 : Character;
107      Nm : TSS_Name_Type;
108
109   begin
110      Get_Last_Two_Chars (Chars (E), C1, C2);
111
112      if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
113         Nm := (C1, C2);
114
115         for J in OK_TSS_Names'Range loop
116            if Nm = OK_TSS_Names (J) then
117               return Nm;
118            end if;
119         end loop;
120      end if;
121
122      return TSS_Null;
123   end Get_TSS_Name;
124
125   ---------------------------------
126   -- Has_Non_Null_Base_Init_Proc --
127   ---------------------------------
128
129   function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
130      BIP : constant Entity_Id := Base_Init_Proc (Typ);
131
132   begin
133      return Present (BIP) and then not Is_Null_Init_Proc (BIP);
134   end Has_Non_Null_Base_Init_Proc;
135
136   ---------------
137   -- Init_Proc --
138   ---------------
139
140   function Init_Proc (Typ : Entity_Id) return Entity_Id is
141      FN   : constant Node_Id := Freeze_Node (Typ);
142      Elmt : Elmt_Id;
143
144   begin
145      if No (FN) then
146         return Empty;
147
148      elsif No (TSS_Elist (FN)) then
149         return Empty;
150
151      else
152         Elmt := First_Elmt (TSS_Elist (FN));
153         while Present (Elmt) loop
154            if Is_Init_Proc (Node (Elmt)) then
155               return Node (Elmt);
156            end if;
157
158            Next_Elmt (Elmt);
159         end loop;
160      end if;
161
162      return Empty;
163   end Init_Proc;
164
165   ------------------
166   -- Is_Init_Proc --
167   ------------------
168
169   function Is_Init_Proc (E : Entity_Id) return Boolean is
170      C1 : Character;
171      C2 : Character;
172   begin
173      Get_Last_Two_Chars (Chars (E), C1, C2);
174      return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
175   end Is_Init_Proc;
176
177   ------------
178   -- Is_TSS --
179   ------------
180
181   function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
182      C1 : Character;
183      C2 : Character;
184   begin
185      Get_Last_Two_Chars (Chars (E), C1, C2);
186      return C1 = Nam (1) and then C2 = Nam (2);
187   end Is_TSS;
188
189   function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
190      C1 : Character;
191      C2 : Character;
192   begin
193      Get_Last_Two_Chars (N, C1, C2);
194      return C1 = Nam (1) and then C2 = Nam (2);
195   end Is_TSS;
196
197   -------------------------
198   -- Make_Init_Proc_Name --
199   -------------------------
200
201   function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
202   begin
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);
207      return Name_Find;
208   end Make_Init_Proc_Name;
209
210   -------------------------
211   -- Make_TSS_Name_Local --
212   -------------------------
213
214   function Make_TSS_Name_Local
215     (Typ : Entity_Id;
216      Nam : TSS_Name_Type) return Name_Id
217   is
218   begin
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);
224      return Name_Find;
225   end Make_TSS_Name_Local;
226
227   -------------------
228   -- Make_TSS_Name --
229   -------------------
230
231   function Make_TSS_Name
232     (Typ : Entity_Id;
233      Nam : TSS_Name_Type) return Name_Id
234   is
235   begin
236      Get_Name_String (Chars (Typ));
237      Add_Char_To_Name_Buffer (Nam (1));
238      Add_Char_To_Name_Buffer (Nam (2));
239      return Name_Find;
240   end Make_TSS_Name;
241
242   --------------
243   -- Same_TSS --
244   --------------
245
246   function Same_TSS (E1, E2 : Entity_Id) return Boolean is
247      E1C1 : Character;
248      E1C2 : Character;
249      E2C1 : Character;
250      E2C2 : Character;
251
252   begin
253      Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
254      Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
255
256      return
257        E1C1 = E2C1
258          and then
259        E1C2 = E2C2
260          and then
261        E1C1 in 'A' .. 'Z'
262          and then
263        E1C2 in 'A' .. 'Z';
264   end Same_TSS;
265
266   -------------------
267   -- Set_Init_Proc --
268   -------------------
269
270   procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
271   begin
272      Set_TSS (Typ, Init);
273   end Set_Init_Proc;
274
275   -------------
276   -- Set_TSS --
277   -------------
278
279   procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
280      Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
281
282   begin
283      --  Case of insertion location is in unit defining the type
284
285      if In_Same_Code_Unit (Typ, TSS) then
286         Append_Freeze_Action (Typ, Subprog_Body);
287
288      --  Otherwise, we are using an already existing TSS in another unit
289
290      else
291         null;
292      end if;
293
294      Copy_TSS (TSS, Typ);
295   end Set_TSS;
296
297   ---------
298   -- TSS --
299   ---------
300
301   function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
302      FN   : constant Node_Id := Freeze_Node (Typ);
303      Elmt : Elmt_Id;
304      Subp : Entity_Id;
305
306   begin
307      if No (FN) then
308         return Empty;
309
310      elsif No (TSS_Elist (FN)) then
311         return Empty;
312
313      else
314         Elmt := First_Elmt (TSS_Elist (FN));
315         while Present (Elmt) loop
316            if Is_TSS (Node (Elmt), Nam) then
317               Subp := Node (Elmt);
318
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.
323
324               if Nkind (Parent (Parent (Subp))) =
325                                           N_Subprogram_Renaming_Declaration
326                 and then
327                   Present (Corresponding_Spec (Parent (Parent (Subp))))
328               then
329                  return Corresponding_Spec (Parent (Parent (Subp)));
330               else
331                  return Subp;
332               end if;
333
334            else
335               Next_Elmt (Elmt);
336            end if;
337         end loop;
338      end if;
339
340      return Empty;
341   end TSS;
342
343   function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
344      FN   : constant Node_Id := Freeze_Node (Typ);
345      Elmt : Elmt_Id;
346      Subp : Entity_Id;
347
348   begin
349      if No (FN) then
350         return Empty;
351
352      elsif No (TSS_Elist (FN)) then
353         return Empty;
354
355      else
356         Elmt := First_Elmt (TSS_Elist (FN));
357         while Present (Elmt) loop
358            if Chars (Node (Elmt)) =  Nam then
359               Subp := Node (Elmt);
360
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.
365
366               if Nkind (Parent (Parent (Subp))) =
367                                           N_Subprogram_Renaming_Declaration
368                 and then
369                   Present (Corresponding_Spec (Parent (Parent (Subp))))
370               then
371                  return Corresponding_Spec (Parent (Parent (Subp)));
372               else
373                  return Subp;
374               end if;
375
376            else
377               Next_Elmt (Elmt);
378            end if;
379         end loop;
380      end if;
381
382      return Empty;
383   end TSS;
384
385end Exp_Tss;
386