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-2020, 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 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.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Elists;   use Elists;
29with Exp_Util; use Exp_Util;
30with Nlists;   use Nlists;
31with Lib;      use Lib;
32with Restrict; use Restrict;
33with Rident;   use Rident;
34with Sem_Aux;  use Sem_Aux;
35with Sem_Ch6;  use Sem_Ch6;
36with Sem_Util; use Sem_Util;
37with Sinfo;    use Sinfo;
38
39package body Exp_Tss is
40
41   --------------------
42   -- Base_Init_Proc --
43   --------------------
44
45   function Base_Init_Proc
46     (Typ : Entity_Id;
47      Ref : Entity_Id := Empty) return Entity_Id
48   is
49      Full_Type : E;
50      Proc      : Entity_Id;
51
52   begin
53      pragma Assert (Is_Type (Typ));
54
55      if Is_Private_Type (Typ) then
56         Full_Type := Underlying_Type (Base_Type (Typ));
57      else
58         Full_Type := Typ;
59      end if;
60
61      if No (Full_Type) then
62         return Empty;
63
64      elsif Is_Concurrent_Type (Full_Type)
65        and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
66      then
67         --  The initialization routine to be called is that of the base type
68         --  of the corresponding record type, which may itself be a subtype
69         --  and possibly an itype.
70
71         return Init_Proc
72           (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
73            Ref);
74
75      else
76         Proc := Init_Proc (Base_Type (Full_Type), Ref);
77
78         if No (Proc)
79           and then Is_Composite_Type (Full_Type)
80           and then Is_Derived_Type (Full_Type)
81         then
82            return Init_Proc (Root_Type (Full_Type), Ref);
83         else
84            return Proc;
85         end if;
86      end if;
87   end Base_Init_Proc;
88
89   --------------
90   -- Copy_TSS --
91   --------------
92
93   --  Note: internally this routine is also used to initially set up
94   --  a TSS entry for a new type (case of being called from Set_TSS)
95
96   procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
97      FN : Node_Id;
98
99   begin
100      Ensure_Freeze_Node (Typ);
101      FN := Freeze_Node (Typ);
102
103      if No (TSS_Elist (FN)) then
104         Set_TSS_Elist (FN, New_Elmt_List);
105      end if;
106
107      --  We prepend here, so that a second call overrides the first, it
108      --  is not clear that this is required, but it seems reasonable.
109
110      Prepend_Elmt (TSS, TSS_Elist (FN));
111   end Copy_TSS;
112
113   -------------------
114   -- CPP_Init_Proc --
115   -------------------
116
117   function CPP_Init_Proc (Typ  : Entity_Id) return Entity_Id is
118      FN   : constant Node_Id := Freeze_Node (Typ);
119      Elmt : Elmt_Id;
120
121   begin
122      if not Is_CPP_Class (Root_Type (Typ))
123        or else No (FN)
124        or else No (TSS_Elist (FN))
125      then
126         return Empty;
127
128      else
129         Elmt := First_Elmt (TSS_Elist (FN));
130         while Present (Elmt) loop
131            if Is_CPP_Init_Proc (Node (Elmt)) then
132               return Node (Elmt);
133            end if;
134
135            Next_Elmt (Elmt);
136         end loop;
137      end if;
138
139      return Empty;
140   end CPP_Init_Proc;
141
142   ------------------------
143   -- Find_Inherited_TSS --
144   ------------------------
145
146   function Find_Inherited_TSS
147     (Typ : Entity_Id;
148      Nam : TSS_Name_Type) return Entity_Id
149   is
150      Btyp : Entity_Id;
151      Proc : Entity_Id;
152
153   begin
154      --  If Typ is a private type, look at the full view
155
156      if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
157         Btyp := Base_Type (Full_View (Typ));
158      else
159         Btyp := Base_Type (Typ);
160      end if;
161
162      Proc := TSS (Btyp, Nam);
163
164      --  If Typ is a derived type, it may inherit attributes from an ancestor
165
166      if No (Proc) and then Is_Derived_Type (Btyp) then
167         if not Derivation_Too_Early_To_Inherit (Btyp, Nam) then
168            Proc := Find_Inherited_TSS (Etype (Btyp), Nam);
169         elsif Is_Derived_Type (Etype (Btyp)) then
170            --  Skip one link in the derivation chain
171            Proc := Find_Inherited_TSS
172                      (Etype (Base_Type (Etype (Btyp))), Nam);
173         end if;
174      end if;
175
176      --  If nothing else, use the TSS of the root type
177
178      if No (Proc) then
179         Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
180      end if;
181
182      return Proc;
183   end Find_Inherited_TSS;
184
185   ------------------
186   -- Get_TSS_Name --
187   ------------------
188
189   function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
190      C1 : Character;
191      C2 : Character;
192      Nm : TSS_Name_Type;
193
194   begin
195      Get_Last_Two_Chars (Chars (E), C1, C2);
196
197      if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
198         Nm := (C1, C2);
199
200         for J in TSS_Names'Range loop
201            if Nm = TSS_Names (J) then
202               return Nm;
203            end if;
204         end loop;
205      end if;
206
207      return TSS_Null;
208   end Get_TSS_Name;
209
210   ---------------------------------
211   -- Has_Non_Null_Base_Init_Proc --
212   ---------------------------------
213
214   --  Note: if a base Init_Proc is present, and No_Default_Initialization is
215   --  present, then we must avoid testing for a null init proc, since there
216   --  is no init proc present in this case.
217
218   function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
219      BIP : constant Entity_Id := Base_Init_Proc (Typ);
220   begin
221      return Present (BIP)
222        and then (Restriction_Active (No_Default_Initialization)
223                   or else not Is_Null_Init_Proc (BIP));
224   end Has_Non_Null_Base_Init_Proc;
225
226   ---------------
227   -- Init_Proc --
228   ---------------
229
230   function Init_Proc
231     (Typ  : Entity_Id;
232      Ref  : Entity_Id := Empty) return Entity_Id
233   is
234      FN   : constant Node_Id := Freeze_Node (Typ);
235      Elmt : Elmt_Id;
236      E1   : Entity_Id;
237      E2   : Entity_Id;
238
239   begin
240      if No (FN) then
241         return Empty;
242
243      elsif No (TSS_Elist (FN)) then
244         return Empty;
245
246      elsif No (Ref) then
247         Elmt := First_Elmt (TSS_Elist (FN));
248         while Present (Elmt) loop
249            if Is_Init_Proc (Node (Elmt)) then
250               if not Is_CPP_Class (Typ) then
251                  return Node (Elmt);
252
253               --  For CPP classes, we are looking for the default constructor,
254               --  and so we must skip any non-default constructor.
255
256               elsif
257                 No (Next
258                      (First
259                        (Parameter_Specifications (Parent (Node (Elmt))))))
260               then
261                  return Node (Elmt);
262               end if;
263            end if;
264
265            Next_Elmt (Elmt);
266         end loop;
267
268      --  Non-default constructors are currently supported only in the context
269      --  of interfacing with C++.
270
271      else pragma Assert (Is_CPP_Class (Typ));
272
273         --  Use the referenced function to locate the init_proc matching
274         --  the C++ constructor.
275
276         Elmt := First_Elmt (TSS_Elist (FN));
277         while Present (Elmt) loop
278            if Is_Init_Proc (Node (Elmt)) then
279               E1 := Next_Formal (First_Formal (Node (Elmt)));
280               E2 := First_Formal (Ref);
281               while Present (E1) and then Present (E2) loop
282                  if Chars (E1) /= Chars (E2)
283                    or else Ekind (E1) /= Ekind (E2)
284                  then
285                     exit;
286
287                  elsif not Is_Anonymous_Access_Type (Etype (E1))
288                    and then not Is_Anonymous_Access_Type (Etype (E2))
289                    and then Etype (E1) /= Etype (E2)
290                  then
291                     exit;
292
293                  elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
294                    and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
295                    and then Directly_Designated_Type (Etype (E1))
296                               /= Directly_Designated_Type (Etype (E2))
297                  then
298                     exit;
299
300                  elsif Ekind (Etype (E1)) in
301                          E_Anonymous_Access_Subprogram_Type |
302                          E_Anonymous_Access_Protected_Subprogram_Type
303                    and then Ekind (Etype (E2)) in
304                               E_Anonymous_Access_Subprogram_Type |
305                               E_Anonymous_Access_Protected_Subprogram_Type
306                    and then not Conforming_Types
307                                   (Etype (E1), Etype (E2), Fully_Conformant)
308                  then
309                     exit;
310                  end if;
311
312                  E1 := Next_Formal (E1);
313                  E2 := Next_Formal (E2);
314               end loop;
315
316               if No (E1) and then No (E2) then
317                  return Node (Elmt);
318               end if;
319            end if;
320
321            Next_Elmt (Elmt);
322         end loop;
323      end if;
324
325      return Empty;
326   end Init_Proc;
327
328   ----------------------
329   -- Is_CPP_Init_Proc --
330   ----------------------
331
332   function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
333      C1 : Character;
334      C2 : Character;
335   begin
336      Get_Last_Two_Chars (Chars (E), C1, C2);
337      return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
338   end Is_CPP_Init_Proc;
339
340   ------------------
341   -- Is_Init_Proc --
342   ------------------
343
344   function Is_Init_Proc (E : Entity_Id) return Boolean is
345      C1 : Character;
346      C2 : Character;
347   begin
348      Get_Last_Two_Chars (Chars (E), C1, C2);
349      return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
350   end Is_Init_Proc;
351
352   ------------
353   -- Is_TSS --
354   ------------
355
356   function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
357      C1 : Character;
358      C2 : Character;
359   begin
360      Get_Last_Two_Chars (Chars (E), C1, C2);
361      return C1 = Nam (1) and then C2 = Nam (2);
362   end Is_TSS;
363
364   function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
365      C1 : Character;
366      C2 : Character;
367   begin
368      Get_Last_Two_Chars (N, C1, C2);
369      return C1 = Nam (1) and then C2 = Nam (2);
370   end Is_TSS;
371
372   -------------------------
373   -- Make_Init_Proc_Name --
374   -------------------------
375
376   function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
377   begin
378      return Make_TSS_Name (Typ, TSS_Init_Proc);
379   end Make_Init_Proc_Name;
380
381   -------------------
382   -- Make_TSS_Name --
383   -------------------
384
385   function Make_TSS_Name
386     (Typ : Entity_Id;
387      Nam : TSS_Name_Type) return Name_Id
388   is
389   begin
390      Get_Name_String (Chars (Typ));
391      Add_Char_To_Name_Buffer (Nam (1));
392      Add_Char_To_Name_Buffer (Nam (2));
393      return Name_Find;
394   end Make_TSS_Name;
395
396   -------------------------
397   -- Make_TSS_Name_Local --
398   -------------------------
399
400   function Make_TSS_Name_Local
401     (Typ : Entity_Id;
402      Nam : TSS_Name_Type) return Name_Id
403   is
404   begin
405      Get_Name_String (Chars (Typ));
406      Add_Char_To_Name_Buffer ('_');
407      Add_Nat_To_Name_Buffer (Increment_Serial_Number);
408      Add_Char_To_Name_Buffer (Nam (1));
409      Add_Char_To_Name_Buffer (Nam (2));
410      return Name_Find;
411   end Make_TSS_Name_Local;
412
413   --------------
414   -- Same_TSS --
415   --------------
416
417   function Same_TSS (E1, E2 : Entity_Id) return Boolean is
418      E1C1 : Character;
419      E1C2 : Character;
420      E2C1 : Character;
421      E2C2 : Character;
422
423   begin
424      Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
425      Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
426
427      return
428        E1C1 = E2C1
429          and then
430        E1C2 = E2C2
431          and then
432        E1C1 in 'A' .. 'Z'
433          and then
434        E1C2 in 'A' .. 'Z';
435   end Same_TSS;
436
437   -------------------
438   -- Set_Init_Proc --
439   -------------------
440
441   procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
442   begin
443      Set_TSS (Typ, Init);
444   end Set_Init_Proc;
445
446   -------------
447   -- Set_TSS --
448   -------------
449
450   procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
451   begin
452      --  Make sure body of subprogram is frozen
453
454      --  Skip this for Init_Proc with No_Default_Initialization, since the
455      --  Init proc is a dummy void entity in this case to be ignored.
456
457      if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
458        and then Restriction_Active (No_Default_Initialization)
459      then
460         null;
461
462      --  Skip this if not in the same code unit (since it means we are using
463      --  an already existing TSS in another unit)
464
465      elsif not In_Same_Code_Unit (Typ, TSS) then
466         null;
467
468      --  Otherwise make sure body is frozen
469
470      else
471         Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
472      end if;
473
474      --  Set TSS entry
475
476      Copy_TSS (TSS, Typ);
477   end Set_TSS;
478
479   ---------
480   -- TSS --
481   ---------
482
483   function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
484      FN   : constant Node_Id := Freeze_Node (Typ);
485      Elmt : Elmt_Id;
486      Subp : Entity_Id;
487
488   begin
489      if No (FN) then
490         return Empty;
491
492      elsif No (TSS_Elist (FN)) then
493         return Empty;
494
495      else
496         Elmt := First_Elmt (TSS_Elist (FN));
497         while Present (Elmt) loop
498            if Is_TSS (Node (Elmt), Nam) then
499               Subp := Node (Elmt);
500
501               --  For stream subprograms, the TSS entity may be a renaming-
502               --  as-body of an already generated entity. Use that one rather
503               --  the one introduced by the renaming, which is an artifact of
504               --  current stream handling.
505
506               if Nkind (Parent (Parent (Subp))) =
507                                           N_Subprogram_Renaming_Declaration
508                 and then
509                   Present (Corresponding_Spec (Parent (Parent (Subp))))
510               then
511                  return Corresponding_Spec (Parent (Parent (Subp)));
512               else
513                  return Subp;
514               end if;
515
516            else
517               Next_Elmt (Elmt);
518            end if;
519         end loop;
520      end if;
521
522      return Empty;
523   end TSS;
524
525end Exp_Tss;
526