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